# This program was posted on the MacPerl mailing list by
# Charles Albrecht as one way to get perltidy to work as a filter
# under BBEdit.
+# 20240102: slh fixed obvious error found with -duv: ('my' inside BEGIN block)
use Perl::Tidy;
-BEGIN { my $input_string = ""; my $output_string = ""; }
+my ($input_string, $output_string);
+BEGIN { $input_string = ""; $output_string = ""; }
$input_string .= $_;
$| = 1;
use vars qw($opt_l $opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+
+ my $usage = <<EOM;
usage: break_long_quotes.pl [ -ln ] filename >outfile
where n=line length (default 72)
EOM
-getopts('hl:') or die "$usage";
-if ($opt_h) { die $usage }
-if ( !defined $opt_l ) {
- $opt_l = 70;
-}
-else {
- $opt_l =~ /^\d+$/ or die "$usage";
-}
+ getopts('hl:') or die "$usage";
+ if ($opt_h) { die $usage }
+ if ( !defined $opt_l ) {
+ $opt_l = 70;
+ }
+ else {
+ $opt_l =~ /^\d+$/ or die "$usage";
+ }
-unless ( @ARGV == 1 ) { die $usage }
-my $file = $ARGV[0];
-scan_file( $file, $opt_l );
+ unless ( @ARGV == 1 ) { die $usage }
+ my $file = $ARGV[0];
+ scan_file( $file, $opt_l );
+}
sub scan_file {
my ( $file, $line_length ) = @_;
unless ($fh) { die "cannot open '$file': $!\n" }
my $formatter = MyWriter->new($line_length);
- my $err=perltidy(
+ my $err = perltidy(
'formatter' => $formatter, # callback object
'source' => $fh,
'argv' => "-npro -se", # don't need .perltidyrc
# errors to STDOUT
);
- if ($err){
+ if ($err) {
die "Error calling perltidy\n";
}
$fh->close();
# find leading whitespace
my $leading_whitespace = ( $input_line =~ /^(\s*)/ ) ? $1 : "";
- if ($starting_in_quote) {$leading_whitespace=""};
+ if ($starting_in_quote) { $leading_whitespace = "" }
my $new_line = $leading_whitespace;
# loop over tokens looking for quotes (token type Q)
# look for long quoted strings on a single line
# (multiple line quotes not currently handled)
if ( $$rtoken_type[$j] eq 'Q'
- && !( $j == 0 && $starting_in_quote )
+ && !( $j == 0 && $starting_in_quote )
&& !( $j == $jmax && $ending_in_quote )
&& ( length($token) > $max_quote_length ) )
{
} ## end if ( $line_type eq 'CODE')
# print the line
- $self->print($input_line."\n");
+ $self->print( $input_line . "\n" );
return;
} ## end sub write_line
# break a string at one or more spaces so that the longest substring is
# less than the desired length (if possible).
my ( $str, $quote_char, $max_length ) = @_;
- my $blank = ' ';
- my $prev_char = "";
+ my $blank = ' ';
my @break_after_pos;
my $quote_pos = -1;
while ( ( $quote_pos = index( $str, $blank, 1 + $quote_pos ) ) >= 0 ) {
# called once after the last line of a file
sub finish_formatting {
my $self = shift;
- $self->flush_comments();
}
# Example script for removing trailing blank lines of code from a perl script
# This is from the examples/ directory of the perltidy distribution and may
-# be modified as needed.
+# be modified as needed.
# This was written in response to RT #118553, "leave only one newline at end of file".
# Adding the requested feature to perltidy itself would have very undesirable
use IO::File;
$| = 1;
use vars qw($opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+ my $usage = <<EOM;
usage: $0 filename >outfile
EOM
-getopts('h') or die "$usage";
-if ($opt_h) { die $usage }
-
-# Make the source for perltidy, which will be a filehandle
-# or just '-' if the source is stdin
-my ($file, $fh, $source);
-if ( @ARGV == 0 ) {
- $source = '-';
-}
-elsif ( @ARGV == 1 ) {
- $file = $ARGV[0];
- $fh = IO::File->new( $file, 'r' );
- unless ($fh) { die "cannot open '$file': $!\n" }
- $source = $fh;
-}
-else { die $usage }
-
-# make the callback object
-my $formatter = MyFormatter->new();
-
-my $dest;
-
-# start perltidy, which will start calling our write_line()
-my $err=perltidy(
- 'formatter' => $formatter, # callback object
- 'source' => $source,
- 'destination' => \$dest, # (not really needed)
- 'argv' => "-npro -se", # dont need .perltidyrc
- # errors to STDOUT
-);
-if ($err) {
- die "Error calling perltidy\n";
+ getopts('h') or die "$usage";
+ if ($opt_h) { die $usage }
+
+ # Make the source for perltidy, which will be a filehandle
+ # or just '-' if the source is stdin
+ my ( $file, $fh, $source );
+ if ( @ARGV == 0 ) {
+ $source = '-';
+ }
+ elsif ( @ARGV == 1 ) {
+ $file = $ARGV[0];
+ $fh = IO::File->new( $file, 'r' );
+ unless ($fh) { die "cannot open '$file': $!\n" }
+ $source = $fh;
+ }
+ else { die $usage }
+
+ # make the callback object
+ my $formatter = MyFormatter->new();
+
+ my $dest;
+
+ # start perltidy, which will start calling our write_line()
+ my $err = perltidy(
+ 'formatter' => $formatter, # callback object
+ 'source' => $source,
+ 'destination' => \$dest, # (not really needed)
+ 'argv' => "-npro -se", # dont need .perltidyrc
+ # errors to STDOUT
+ );
+ if ($err) {
+ die "Error calling perltidy\n";
+ }
+ $fh->close() if $fh;
+ return;
}
-$fh->close() if $fh;
package MyFormatter;
sub write_line {
# This is called from perltidy line-by-line; we just save lines
- my $self = shift;
- my $line_of_tokens = shift;
+ my $self = shift;
+ my $line_of_tokens = shift;
push @lines, $line_of_tokens;
}
my $self = shift;
# remove all trailing blank lines of code
- while (my $line_of_tokens = pop(@lines)) {
- my $line_type = $line_of_tokens->{_line_type};
- my $input_line = $line_of_tokens->{_line_text};
+ while ( my $line_of_tokens = pop(@lines) ) {
+ my $line_type = $line_of_tokens->{_line_type};
+ my $input_line = $line_of_tokens->{_line_text};
if ( $line_type eq 'CODE' ) {
chomp $input_line;
next unless ($input_line);
}
- push @lines, $line_of_tokens;
- last;
+ push @lines, $line_of_tokens;
+ last;
}
# write remaining lines
foreach my $line_of_tokens (@lines) {
- my $line_type = $line_of_tokens->{_line_type};
- my $input_line = $line_of_tokens->{_line_text};
- print $input_line;
+ my $line_type = $line_of_tokens->{_line_type};
+ my $input_line = $line_of_tokens->{_line_text};
+ print $input_line;
}
return;
}
#
# usage:
# find_naughty file1 [file2 [...]]
-# find_naughty <file.pl
+# find_naughty <file.pl
#
# Author: Steve Hancock, July 2003
#
use IO::File;
$| = 1;
use vars qw($opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+ my $usage = <<EOM;
usage:
find_naughty file1 [file2 [...]]
find_naughty <file.pl
EOM
-getopts('h') or die "$usage";
-if ($opt_h) { die $usage }
+ getopts('h') or die "$usage";
+ if ($opt_h) { die $usage }
-unless (@ARGV) { unshift @ARGV, '-' } # stdin
-foreach my $source (@ARGV) {
- PerlTokenSearch::find_naughty(
- _source => $source,
- );
+ unless (@ARGV) { unshift @ARGV, '-' } # stdin
+ foreach my $source (@ARGV) {
+ PerlTokenSearch::find_naughty( _source => $source, );
+ }
+ return;
}
#####################################################################
# source filehandle and looks for selected variables.
#
# It works by making a callback object with a write_line() method to
-# receive tokenized lines from perltidy.
+# receive tokenized lines from perltidy.
#
# Usage:
#
sub find_naughty {
- my %args = ( @_ );
+ my %args = (@_);
print "Testing File: $args{_source}\n";
# run perltidy, which will call $formatter's write_line() for each line
- my $err=perltidy(
+ my $err = perltidy(
'source' => $args{_source},
'formatter' => bless( \%args, __PACKAGE__ ), # callback object
- 'argv' => "-npro -se", # -npro : ignore .perltidyrc,
- # -se : errors to STDOUT
+ 'argv' => "-npro -se", # -npro : ignore .perltidyrc,
+ # -se : errors to STDOUT
);
if ($err) {
die "Error calling perltidy\n";
# This is called back from perltidy line-by-line
# We're looking for $`, $&, and $'
my ( $self, $line_of_tokens ) = @_;
- my $source = $self->{_source};
+ my $source = $self->{_source};
# pull out some stuff we might need
my $line_type = $line_of_tokens->{_line_type};
# and check it
if ( $token =~ /^\$[\`\&\']$/ ) {
- print STDERR
- "$source:$input_line_number: $token\n";
+ print STDERR "$source:$input_line_number: $token\n";
}
}
}
$| = 1;
use vars qw($opt_l $opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+ my $usage = <<EOM;
usage: perlcomment [ -ln ] filename >outfile
where n=line length (default 72)
EOM
-getopts('hl:') or die "$usage";
-if ($opt_h) { die $usage }
-if ( !defined $opt_l ) {
- $opt_l = 72;
-}
-else {
- $opt_l =~ /^\d+$/ or die "$usage";
-}
+ getopts('hl:') or die "$usage";
+ if ($opt_h) { die $usage }
+ if ( !defined $opt_l ) {
+ $opt_l = 72;
+ }
+ else {
+ $opt_l =~ /^\d+$/ or die "$usage";
+ }
-unless ( @ARGV == 1 ) { die $usage }
-my $file = $ARGV[0];
-autoformat_file( $file, $opt_l );
+ unless ( @ARGV == 1 ) { die $usage }
+ my $file = $ARGV[0];
+ autoformat_file( $file, $opt_l );
+ return;
+}
sub autoformat_file {
my ( $file, $line_length ) = @_;
use IO::File;
$| = 1;
use vars qw($opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+ my $usage = <<EOM;
usage: perllinetype filename >outfile
EOM
-getopts('h') or die "$usage";
-if ($opt_h) { die $usage }
+ getopts('h') or die "$usage";
+ if ($opt_h) { die $usage }
-# Make the source for perltidy, which will be a filehandle
-# or just '-' if the source is stdin
-my ($file, $fh, $source);
-if ( @ARGV == 0 ) {
- $source = '-';
-}
-elsif ( @ARGV == 1 ) {
- $file = $ARGV[0];
- $fh = IO::File->new( $file, 'r' );
- unless ($fh) { die "cannot open '$file': $!\n" }
- $source = $fh;
-}
-else { die $usage }
+ # Make the source for perltidy, which will be a filehandle
+ # or just '-' if the source is stdin
+ my ( $file, $fh, $source );
+ if ( @ARGV == 0 ) {
+ $source = '-';
+ }
+ elsif ( @ARGV == 1 ) {
+ $file = $ARGV[0];
+ $fh = IO::File->new( $file, 'r' );
+ unless ($fh) { die "cannot open '$file': $!\n" }
+ $source = $fh;
+ }
+ else { die $usage }
-# make the callback object
-my $formatter = MyFormatter->new();
+ # make the callback object
+ my $formatter = MyFormatter->new();
-my $dest;
+ my $dest;
-# start perltidy, which will start calling our write_line()
-my $err=perltidy(
- 'formatter' => $formatter, # callback object
- 'source' => $source,
- 'destination' => \$dest, # (not really needed)
- 'argv' => "-npro -se", # dont need .perltidyrc
- # errors to STDOUT
-);
-if ($err) {
- die "Error calling perltidy\n";
+ # start perltidy, which will start calling our write_line()
+ my $err = perltidy(
+ 'formatter' => $formatter, # callback object
+ 'source' => $source,
+ 'destination' => \$dest, # (not really needed)
+ 'argv' => "-npro -se", # dont need .perltidyrc
+ # errors to STDOUT
+ );
+ if ($err) {
+ die "Error calling perltidy\n";
+ }
+ $fh->close() if $fh;
}
-$fh->close() if $fh;
package MyFormatter;
use IO::File;
$| = 1;
use vars qw($opt_c $opt_h);
-my $usage = <<EOM;
+main();
+
+sub main {
+ my $usage = <<EOM;
usage: perlmask [ -cn ] filename >outfile
EOM
-getopts('c:h') or die "$usage";
-if ($opt_h) { die $usage }
-unless ( defined($opt_c) ) { $opt_c = 0 }
-if (@ARGV > 1) { die $usage }
+ getopts('c:h') or die "$usage";
+ if ($opt_h) { die $usage }
+ unless ( defined($opt_c) ) { $opt_c = 0 }
+ if ( @ARGV > 1 ) { die $usage }
-my $source=$ARGV[0]; # an undefined filename will become stdin
+ my $source = $ARGV[0]; # an undefined filename will become stdin
-# strings to hold the files (arrays could be used to)
-my ( $masked_file, $original_file );
+ # strings to hold the files (arrays could be used to)
+ my ( $masked_file, $original_file );
-PerlMask::perlmask(
- _source => $source,
- _rmasked_file => \$masked_file,
- _roriginal_file => \$original_file, # optional
- _compression => $opt_c # optional, default=0
-);
+ PerlMask::perlmask(
+ _source => $source,
+ _rmasked_file => \$masked_file,
+ _roriginal_file => \$original_file, # optional
+ _compression => $opt_c # optional, default=0
+ );
-# Now we have the masked and original files in strings of equal length.
-# We could search for specific text in the masked file here. But here
-# we'll just print the masked file:
-if ($masked_file) { print $masked_file; }
+ # Now we have the masked and original files in strings of equal length.
+ # We could search for specific text in the masked file here. But here
+ # we'll just print the masked file:
+ if ($masked_file) { print $masked_file; }
+ return;
+}
#####################################################################
#
sub perlmask {
- my %args = ( _compression => 0, @_ );
+ my %args = ( _compression => 0, @_ );
my $rfile = $args{_rmasked_file};
unless ( defined($rfile) ) {
croak
"Missing required parameter '_rmasked_file' in call to perlmask\n";
}
- my $ref=ref($rfile);
+ my $ref = ref($rfile);
unless ( $ref =~ /^(SCALAR|ARRAY)$/ ) {
- croak <<EOM;
+ croak <<EOM;
Expecting _rmasked_file = ref to SCALAR or ARRAY in perlmask but got : ($ref)
EOM
}
# run perltidy, which will call $formatter's write_line() for each line
- my $err=perltidy(
+ my $err = perltidy(
'source' => $args{_source},
'formatter' => bless( \%args, __PACKAGE__ ), # callback object
- 'argv' => "-npro -se", # -npro : ignore .perltidyrc,
- # -se : errors to STDOUT
+ 'argv' => "-npro -se", # -npro : ignore .perltidyrc,
+ # -se : errors to STDOUT
);
if ($err) {
die "Error calling perltidy\n";
my $len = length($input_line);
if ( $opt_c == 0 && $len > 0 ) {
print_line( $roriginal_file, $input_line ) if $roriginal_file;
- print_line( $rmasked_file, '#' x $len );
+ print_line( $rmasked_file, '#' x $len );
}
else {
print_line( $roriginal_file, $input_line ) if $roriginal_file;
- print_line( $rmasked_file, "" );
+ print_line( $rmasked_file, "" );
}
return;
}
if ( $opt_c <= 1 ) {
# Find leading whitespace. But be careful..we don't want the
- # whitespace if it is part of quoted text, because it will
+ # whitespace if it is part of quoted text, because it will
# already be contained in a token.
if ( $input_line =~ /^(\s+)/ && !$line_of_tokens->{_starting_in_quote} )
{
}
}
print_line( $roriginal_file, $input_line ) if $roriginal_file;
- print_line( $rmasked_file, $masked_line );
+ print_line( $rmasked_file, $masked_line );
# self-check lengths; this error should never happen
if ( $opt_c == 0 && length($masked_line) != length($input_line) ) {
#
# Steve Hancock, June 2006
#
-my $usage = <<EOM;
+main();
+sub main {
+ my $usage = <<EOM;
usage:
perltidyrc_dump.pl [-d -s -q -h] [ filename ]
filename is the name of a .perltidyrc config file to dump, or
-q quiet: no comments
-h help
EOM
-use Getopt::Std;
-my %my_opts;
-my $cmdline = $0 . " " . join " ", @ARGV;
-getopts( 'hdsq', \%my_opts ) or die "$usage";
-if ( $my_opts{h} ) { die "$usage" }
-if ( @ARGV > 1 ) { die "$usage" }
-
-my $config_file = $ARGV[0];
-my (
- $error_message, $rOpts, $rGetopt_flags,
- $rsections, $rabbreviations, $rOpts_default,
- $rabbreviations_default,
-
-) = read_perltidyrc($config_file);
-
-# always check the error message first
-if ($error_message) {
- die "$error_message\n";
-}
+ use Getopt::Std;
+ my %my_opts;
+ my $cmdline = $0 . " " . join " ", @ARGV;
+ getopts( 'hdsq', \%my_opts ) or die "$usage";
+ if ( $my_opts{h} ) { die "$usage" }
+ if ( @ARGV > 1 ) { die "$usage" }
+
+ my $config_file = $ARGV[0];
+ my (
+ $error_message, $rOpts, $rGetopt_flags,
+ $rsections, $rabbreviations, $rOpts_default,
+ $rabbreviations_default,
+
+ ) = read_perltidyrc($config_file);
+
+ # always check the error message first
+ if ($error_message) {
+ die "$error_message\n";
+ }
-# make a list of perltidyrc options which are same as default
-my %equals_default;
-foreach my $long_name ( keys %{$rOpts} ) {
- my $val = $rOpts->{$long_name};
- if ( defined( $rOpts_default->{$long_name} ) ) {
- my $val2 = $rOpts_default->{$long_name};
- if ( defined($val2) && defined($val) ) {
- $equals_default{$long_name} = ( $val2 eq $val );
+ # make a list of perltidyrc options which are same as default
+ my %equals_default;
+ foreach my $long_name ( keys %{$rOpts} ) {
+ my $val = $rOpts->{$long_name};
+ if ( defined( $rOpts_default->{$long_name} ) ) {
+ my $val2 = $rOpts_default->{$long_name};
+ if ( defined($val2) && defined($val) ) {
+ $equals_default{$long_name} = ( $val2 eq $val );
+ }
}
}
-}
-# Optional: minimize the perltidyrc file length by deleting long_names
-# in $rOpts which are also in $rOpts_default and have the same value.
-# This would be useful if a perltidyrc file has been constructed from a
-# full parameter dump, for example.
-if ( $my_opts{d} ) {
- foreach my $long_name ( keys %{$rOpts} ) {
- delete $rOpts->{$long_name} if $equals_default{$long_name};
+ # Optional: minimize the perltidyrc file length by deleting long_names
+ # in $rOpts which are also in $rOpts_default and have the same value.
+ # This would be useful if a perltidyrc file has been constructed from a
+ # full parameter dump, for example.
+ if ( $my_opts{d} ) {
+ foreach my $long_name ( keys %{$rOpts} ) {
+ delete $rOpts->{$long_name} if $equals_default{$long_name};
+ }
}
-}
-# find user-defined abbreviations
-my %abbreviations_user;
-foreach my $key ( keys %$rabbreviations ) {
- unless ( $rabbreviations_default->{$key} ) {
- $abbreviations_user{$key} = $rabbreviations->{$key};
+ # find user-defined abbreviations
+ my %abbreviations_user;
+ foreach my $key ( keys %$rabbreviations ) {
+ unless ( $rabbreviations_default->{$key} ) {
+ $abbreviations_user{$key} = $rabbreviations->{$key};
+ }
}
-}
-# dump the options, if any
-if ( %$rOpts || %abbreviations_user ) {
- dump_options( $cmdline, \%my_opts, $rOpts, $rGetopt_flags, $rsections,
- $rabbreviations, \%equals_default, \%abbreviations_user );
-}
-else {
- if ($config_file) {
- print STDERR <<EOM;
-No configuration parameters seen in file: $config_file
-EOM
+ # dump the options, if any
+ if ( %$rOpts || %abbreviations_user ) {
+ dump_options( $cmdline, \%my_opts, $rOpts, $rGetopt_flags, $rsections,
+ $rabbreviations, \%equals_default, \%abbreviations_user );
}
else {
- print STDERR <<EOM;
+ if ($config_file) {
+ print STDERR <<EOM;
+No configuration parameters seen in file: $config_file
+EOM
+ }
+ else {
+ print STDERR <<EOM;
No .perltidyrc file found, use perltidy -dpro to see locations checked.
EOM
+ }
}
}
# build a table for long_name->short_name abbreviations
my %short_name;
- foreach my $abbrev ( keys %{$rabbreviations} ) {
- foreach my $abbrev ( sort keys %$rabbreviations ) {
- my @list = @{ $$rabbreviations{$abbrev} };
-
- # an abbreviation may expand into one or more other words,
- # but only those that expand to a single word (which must be
- # one of the long names) are the short names that we want
- # here.
- next unless @list == 1;
- my $long_name = $list[0];
- $short_name{$long_name} = $abbrev;
- }
+ foreach my $abbrev ( sort keys %$rabbreviations ) {
+ my @list = @{ $$rabbreviations{$abbrev} };
+
+ # an abbreviation may expand into one or more other words,
+ # but only those that expand to a single word (which must be
+ # one of the long names) are the short names that we want
+ # here.
+ next unless @list == 1;
+ my $long_name = $list[0];
+ $short_name{$long_name} = $abbrev;
}
unless ( $rmy_opts->{q} ) {
use IO::File;
use Getopt::Std;
use vars qw($opt_h);
-my $file;
-my $usage = <<EOM;
+
+main();
+
+sub main {
+ my $file;
+ my $usage = <<EOM;
usage: perlxmltok filename >outfile
EOM
-getopts('h') or die "$usage";
-if ($opt_h) {die $usage}
-if ( @ARGV == 1 ) {
- $file = $ARGV[0];
-}
-else { die $usage }
-my $source;
-my $fh;
-if ($file) {
- $fh = IO::File->new( $file, 'r' );
- unless ($fh) { die "cannot open '$file': $!\n" }
- $source = $fh;
-}
-else {
- $source = '-';
-}
-my $formatter = Perl::Tidy::XmlWriter->new($file);
-my $dest;
-
-# start perltidy, which will start calling our write_line()
-my $err = perltidy(
- 'formatter' => $formatter, # callback object
- 'source' => $source,
- 'destination' => \$dest, # not really needed
- 'argv' => "-npro -se", # dont need .perltidyrc
- # errors to STDOUT
-);
-if ($err) {
- die "Error calling perltidy\n";
+ getopts('h') or die "$usage";
+ if ($opt_h) { die $usage }
+ if ( @ARGV == 1 ) {
+ $file = $ARGV[0];
+ }
+ else { die $usage }
+ my $source;
+ my $fh;
+ if ($file) {
+ $fh = IO::File->new( $file, 'r' );
+ unless ($fh) { die "cannot open '$file': $!\n" }
+ $source = $fh;
+ }
+ else {
+ $source = '-';
+ }
+ my $formatter = Perl::Tidy::XmlWriter->new($file);
+ my $dest;
+
+ # start perltidy, which will start calling our write_line()
+ my $err = perltidy(
+ 'formatter' => $formatter, # callback object
+ 'source' => $source,
+ 'destination' => \$dest, # not really needed
+ 'argv' => "-npro -se", # dont need .perltidyrc
+ # errors to STDOUT
+ );
+ if ($err) {
+ die "Error calling perltidy\n";
+ }
+ $fh->close() if $fh;
+ return;
}
-$fh->close() if $fh;
#####################################################################
#
sub markup_tokens {
my $self = shift;
my ( $rtokens, $rtoken_type ) = @_;
- my ( @marked_tokens, $j, $string, $type, $token );
+ my ( @marked_tokens, $j, $type, $token );
for ( $j = 0 ; $j < @$rtoken_type ; $j++ ) {
$type = $$rtoken_type[$j];
projects / perltidy.git / commitdiff