2 ###########################################################
4 # perltidy - a perl script indenter and formatter
6 # Copyright (c) 2000-2022 by Steve Hancock
7 # Distributed under the GPL license agreement; see file COPYING
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License along
20 # with this program; if not, write to the Free Software Foundation, Inc.,
21 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
23 # For brief instructions, try 'perltidy -h'.
24 # For more complete documentation, try 'man perltidy'
25 # or visit http://perltidy.sourceforge.net
27 # This script is an example of the default style. It was formatted with:
31 # Code Contributions: See ChangeLog.html for a complete history.
32 # Michael Cartmell supplied code for adaptation to VMS and helped with
34 # Hugh S. Myers supplied sub streamhandle and the supporting code to
35 # create a Perl::Tidy module which can operate on strings, arrays, etc.
36 # Yves Orton supplied coding to help detect Windows versions.
37 # Axel Rose supplied a patch for MacPerl.
38 # Sebastien Aperghis-Tramoni supplied a patch for the defined or operator.
39 # Dan Tyrell contributed a patch for binary I/O.
40 # Ueli Hugenschmidt contributed a patch for -fpsc
41 # Sam Kington supplied a patch to identify the initial indentation of
43 # jonathan swartz supplied patches for:
44 # * .../ pattern, which looks upwards from directory
45 # * --notidy, to be used in directories where we want to avoid
46 # accidentally tidying
47 # * prefilter and postfilter
50 # Many others have supplied key ideas, suggestions, and bug reports;
51 # see the CHANGES file.
53 ############################################################
57 # perlver reports minimum version needed is 5.8.0
58 # 5.004 needed for IO::File
59 # 5.008 needed for wide characters
65 use English qw( -no_match_vars );
66 use Digest::MD5 qw(md5_hex);
67 use Perl::Tidy::Debugger;
68 use Perl::Tidy::DevNull;
69 use Perl::Tidy::Diagnostics;
70 use Perl::Tidy::FileWriter;
71 use Perl::Tidy::Formatter;
72 use Perl::Tidy::HtmlWriter;
73 use Perl::Tidy::IOScalar;
74 use Perl::Tidy::IOScalarArray;
75 use Perl::Tidy::IndentationItem;
76 use Perl::Tidy::LineSink;
77 use Perl::Tidy::LineSource;
78 use Perl::Tidy::Logger;
79 use Perl::Tidy::Tokenizer;
80 use Perl::Tidy::VerticalAligner;
81 local $OUTPUT_AUTOFLUSH = 1;
83 # DEVEL_MODE can be turned on for extra checking during development
84 use constant DEVEL_MODE => 0;
85 use constant EMPTY_STRING => q{};
86 use constant SPACE => q{ };
94 @ISA = qw( Exporter );
95 @EXPORT = qw( &perltidy );
103 use File::Temp qw(tempfile);
107 # Release version is the approximate YYYYMMDD of the release.
108 # Development version is (Last Release).(Development Number)
110 # To make the number continually increasing, the Development Number is a 2
111 # digit number starting at 01 after a release. It is continually bumped
112 # along at significant points during development. If it ever reaches 99
113 # then the Release version must be bumped, and it is probably past time for
116 $VERSION = '20221112';
121 # required to avoid call to AUTOLOAD in some versions of perl
126 # Catch any undefined sub calls so that we are sure to get
127 # some diagnostic information. This sub should never be called
128 # except for a programming error.
130 return if ( $AUTOLOAD =~ /\bDESTROY$/ );
131 my ( $pkg, $fname, $lno ) = caller();
133 ======================================================================
134 Unexpected call to Autoload looking for sub $AUTOLOAD
135 Called from package: '$pkg'
136 Called from File '$fname' at line '$lno'
137 This error is probably due to a recent programming change
138 ======================================================================
141 } ## end sub AUTOLOAD
145 # given filename and mode (r or w), create an object which:
146 # has a 'getline' method if mode='r', and
147 # has a 'print' method if mode='w'.
148 # The objects also need a 'close' method.
150 # How the object is made:
152 # if $filename is: Make object using:
153 # ---------------- -----------------
154 # '-' (STDIN if mode = 'r', STDOUT if mode='w')
156 # ARRAY ref Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
157 # STRING ref Perl::Tidy::IOScalar (formerly IO::Scalar)
159 # (check for 'print' method for 'w' mode)
160 # (check for 'getline' method for 'r' mode)
162 # An optional flag $is_encoded_data may be given, as follows:
164 # Case 1. Any non-empty string: encoded data is being transferred, set
165 # encoding to be utf8 for files and for stdin.
167 # Case 2. Not given, or an empty string: unencoded binary data is being
168 # transferred, set binary mode for files and for stdin.
170 my ( $filename, $mode, $is_encoded_data ) = @_;
172 my $ref = ref($filename);
178 if ( $ref eq 'ARRAY' ) {
179 $New = sub { Perl::Tidy::IOScalarArray->new( $filename, $mode ) };
181 elsif ( $ref eq 'SCALAR' ) {
182 $New = sub { Perl::Tidy::IOScalar->new( $filename, $mode ) };
186 # Accept an object with a getline method for reading. Note:
187 # IO::File is built-in and does not respond to the defined
188 # operator. If this causes trouble, the check can be
189 # skipped and we can just let it crash if there is no
191 if ( $mode =~ /[rR]/ ) {
193 # RT#97159; part 1 of 2: updated to use 'can'
194 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
195 if ( $ref->can('getline') ) {
196 $New = sub { $filename };
199 $New = sub { undef };
201 ------------------------------------------------------------------------
202 No 'getline' method is defined for object of class '$ref'
203 Please check your call to Perl::Tidy::perltidy. Trace follows.
204 ------------------------------------------------------------------------
209 # Accept an object with a print method for writing.
210 # See note above about IO::File
211 if ( $mode =~ /[wW]/ ) {
213 # RT#97159; part 2 of 2: updated to use 'can'
214 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
215 if ( $ref->can('print') ) {
216 $New = sub { $filename };
219 $New = sub { undef };
221 ------------------------------------------------------------------------
222 No 'print' method is defined for object of class '$ref'
223 Please check your call to Perl::Tidy::perltidy. Trace follows.
224 ------------------------------------------------------------------------
233 if ( $filename eq '-' ) {
234 $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
237 $New = sub { IO::File->new( $filename, $mode ) };
240 $fh = $New->( $filename, $mode );
243 Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n");
248 # Case 1: handle encoded data
249 if ($is_encoded_data) {
250 if ( ref($fh) eq 'IO::File' ) {
251 ## binmode object call not available in older perl versions
252 ## $fh->binmode(":raw:encoding(UTF-8)");
253 binmode $fh, ":raw:encoding(UTF-8)";
255 elsif ( $filename eq '-' ) {
256 binmode STDOUT, ":raw:encoding(UTF-8)";
263 # Case 2: handle unencoded data
265 if ( ref($fh) eq 'IO::File' ) { binmode $fh }
266 elsif ( $filename eq '-' ) { binmode STDOUT }
267 else { } # shouldn't happen
271 return $fh, ( $ref or $filename );
272 } ## end sub streamhandle
274 sub find_input_line_ending {
276 # Peek at a file and return first line ending character.
277 # Return undefined value in case of any trouble.
278 my ($input_file) = @_;
281 # silently ignore input from object or stdin
282 if ( ref($input_file) || $input_file eq '-' ) {
287 open( $fh, '<', $input_file ) || return $ending;
291 read( $fh, $buf, 1024 );
292 close $fh || return $ending;
293 if ( $buf && $buf =~ /([\012\015]+)/ ) {
297 if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
300 elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
303 elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
313 } ## end sub find_input_line_ending
315 { ## begin closure for sub catfile
317 my $missing_file_spec;
320 $missing_file_spec = !eval { require File::Spec; 1 };
325 # concatenate a path and file basename
326 # returns undef in case of error
330 # use File::Spec if we can
331 unless ($missing_file_spec) {
332 return File::Spec->catfile(@parts);
335 # Perl 5.004 systems may not have File::Spec so we'll make
336 # a simple try. We assume File::Basename is available.
337 # return if not successful.
338 my $name = pop @parts;
339 my $path = join '/', @parts;
340 my $test_file = $path . $name;
341 my ( $test_name, $test_path ) = fileparse($test_file);
342 return $test_file if ( $test_name eq $name );
343 return if ( $OSNAME eq 'VMS' );
345 # this should work at least for Windows and Unix:
346 $test_file = $path . '/' . $name;
347 ( $test_name, $test_path ) = fileparse($test_file);
348 return $test_file if ( $test_name eq $name );
351 } ## end closure for sub catfile
353 # Here is a map of the flow of data from the input source to the output
356 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
357 # input groups output
358 # lines tokens lines of lines lines
361 # The names correspond to the package names responsible for the unit processes.
363 # The overall process is controlled by the "main" package.
365 # LineSource is the stream of input lines
367 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
368 # if necessary. A token is any section of the input line which should be
369 # manipulated as a single entity during formatting. For example, a single
370 # ',' character is a token, and so is an entire side comment. It handles
371 # the complexities of Perl syntax, such as distinguishing between '<<' as
372 # a shift operator and as a here-document, or distinguishing between '/'
373 # as a divide symbol and as a pattern delimiter.
375 # Formatter inserts and deletes whitespace between tokens, and breaks
376 # sequences of tokens at appropriate points as output lines. It bases its
377 # decisions on the default rules as modified by any command-line options.
379 # VerticalAligner collects groups of lines together and tries to line up
380 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
382 # FileWriter simply writes lines to the output stream.
384 # The Logger package, not shown, records significant events and warning
385 # messages. It writes a .LOG file, which may be saved with a
386 # '-log' or a '-g' flag.
388 { #<<< (this side comment avoids excessive indentation in a closure)
392 my $loaded_unicode_gcstring;
395 # Bump Warn_count only: it is essential to bump the count on all warnings, even
396 # if no message goes out, so that the correct exit status is set.
397 sub Warn_count_bump { $Warn_count++; return }
399 # Output Warn message only
400 sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return }
402 # Output Warn message and bump Warn count
403 sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
410 # true if $string is in Perl's internal character mode
411 # (also called the 'upgraded form', or UTF8=1)
412 # false if $string is in Perl's internal byte mode
414 # This function isolates the call to Perl's internal function
415 # utf8::is_utf8() which is true for strings represented in an 'upgraded
416 # form'. It is available after Perl version 5.8.
417 # See https://perldoc.perl.org/Encode.
418 # See also comments in Carp.pm and other modules using this function
420 return 1 if ( utf8::is_utf8($string) );
422 } ## end sub is_char_mode
427 # Evaluate the MD5 sum for a string
428 # Patch for [rt.cpan.org #88020]
429 # Use utf8::encode since md5_hex() only operates on bytes.
430 # my $digest = md5_hex( utf8::encode($sink_buffer) );
432 # Note added 20180114: the above patch did not work correctly. I'm not
433 # sure why. But switching to the method recommended in the Perl 5
434 # documentation for Encode worked. According to this we can either use
435 # $octets = encode_utf8($string) or equivalently
436 # $octets = encode("utf8",$string)
437 # and then calculate the checksum. So:
438 my $octets = Encode::encode( "utf8", $buf );
439 my $digest = md5_hex($octets);
445 # Array index names for $self.
446 # Do not combine with other BEGIN blocks (c101).
449 _actual_output_extension_ => $i++,
450 _debugfile_stream_ => $i++,
451 _decoded_input_as_ => $i++,
452 _destination_stream_ => $i++,
453 _diagnostics_object_ => $i++,
454 _display_name_ => $i++,
455 _file_extension_separator_ => $i++,
457 _is_encoded_data_ => $i++,
458 _length_function_ => $i++,
459 _line_separator_ => $i++,
460 _logger_object_ => $i++,
461 _output_file_ => $i++,
462 _postfilter_ => $i++,
467 _teefile_stream_ => $i++,
468 _user_formatter_ => $i++,
478 destination => undef,
487 dump_options => undef,
488 dump_options_type => undef,
489 dump_getopt_flags => undef,
490 dump_options_category => undef,
491 dump_options_range => undef,
492 dump_abbreviations => undef,
497 # Status information which can be returned for diagnostic purposes.
498 # NOTE: This is intended only for testing and subject to change.
500 # List of "key => value" hash entries:
502 # Some relevant user input parameters for convenience:
503 # opt_format => value of --format: 'tidy', 'html', or 'user'
504 # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
505 # opt_encode_output => value of -eos flag: 'eos' or 'neos'
506 # opt_max_iterations => value of --iterations=n
508 # file_count => number of files processed in this call
510 # If multiple files are processed, then the following values will be for
511 # the last file only:
513 # input_name => name of the input stream
514 # output_name => name of the output stream
516 # The following two variables refer to Perl's two internal string modes,
517 # and have the values 0 for 'byte' mode and 1 for 'char' mode:
518 # char_mode_source => true if source is in 'char' mode. Will be false
519 # unless we received a source string ref with utf8::is_utf8() set.
520 # char_mode_used => true if text processed by perltidy in 'char' mode.
521 # Normally true for text identified as utf8, otherwise false.
523 # This tells if Unicode::GCString was used
524 # gcs_used => true if -gcs and Unicode::GCString found & used
526 # These variables tell what utf8 decoding/encoding was done:
527 # input_decoded_as => non-blank if perltidy decoded the source text
528 # output_encoded_as => non-blank if perltidy encoded before return
530 # These variables are related to iterations and convergence testing:
531 # iteration_count => number of iterations done
532 # ( can be from 1 to opt_max_iterations )
533 # converged => true if stopped on convergence
534 # ( can only happen if opt_max_iterations > 1 )
535 # blinking => true if stopped on blinking states
536 # ( i.e., unstable formatting, should not happen )
541 opt_format => EMPTY_STRING,
542 opt_encoding => EMPTY_STRING,
543 opt_encode_output => EMPTY_STRING,
544 opt_max_iterations => EMPTY_STRING,
546 input_name => EMPTY_STRING,
547 output_name => EMPTY_STRING,
548 char_mode_source => 0,
550 input_decoded_as => EMPTY_STRING,
551 output_encoded_as => EMPTY_STRING,
553 iteration_count => 0,
558 # Fix for issue git #57
561 # don't overwrite callers ARGV
563 local *STDERR = *STDERR;
565 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
566 local $LIST_SEPARATOR = ')(';
567 my @good_keys = sort keys %defaults;
568 @bad_keys = sort @bad_keys;
570 ------------------------------------------------------------------------
571 Unknown perltidy parameter : (@bad_keys)
572 perltidy only understands : (@good_keys)
573 ------------------------------------------------------------------------
578 my $get_hash_ref = sub {
580 my $hash_ref = $input_hash{$key};
581 if ( defined($hash_ref) ) {
582 unless ( ref($hash_ref) eq 'HASH' ) {
583 my $what = ref($hash_ref);
585 $what ? "but is ref to $what" : "but is not a reference";
587 ------------------------------------------------------------------------
588 error in call to perltidy:
589 -$key must be reference to HASH $but_is
590 ------------------------------------------------------------------------
597 %input_hash = ( %defaults, %input_hash );
598 my $argv = $input_hash{'argv'};
599 my $destination_stream = $input_hash{'destination'};
600 my $errorfile_stream = $input_hash{'errorfile'};
601 my $logfile_stream = $input_hash{'logfile'};
602 my $teefile_stream = $input_hash{'teefile'};
603 my $debugfile_stream = $input_hash{'debugfile'};
604 my $perltidyrc_stream = $input_hash{'perltidyrc'};
605 my $source_stream = $input_hash{'source'};
606 my $stderr_stream = $input_hash{'stderr'};
607 my $user_formatter = $input_hash{'formatter'};
608 my $prefilter = $input_hash{'prefilter'};
609 my $postfilter = $input_hash{'postfilter'};
611 if ($stderr_stream) {
612 ( $fh_stderr, my $stderr_file ) =
613 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
616 ------------------------------------------------------------------------
617 Unable to redirect STDERR to $stderr_stream
618 Please check value of -stderr in call to perltidy
619 ------------------------------------------------------------------------
624 $fh_stderr = *STDERR;
628 bless $self, __PACKAGE__;
632 if ($flag) { goto ERROR_EXIT }
633 else { goto NORMAL_EXIT }
634 croak "unexpectd return to Exit";
641 croak "unexpected return to Die";
647 # This routine is called for errors that really should not occur
648 # except if there has been a bug introduced by a recent program change.
649 # Please add comments at calls to Fault to explain why the call
650 # should not occur, and where to look to fix it.
651 my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
652 my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
653 my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
655 my $input_stream_name = $rstatus->{'input_name'};
656 $input_stream_name = '(unknown)' unless ($input_stream_name);
658 ==============================================================================
659 While operating on input stream with name: '$input_stream_name'
660 A fault was detected at line $line0 of sub '$subroutine1'
662 which was called from line $line1 of sub '$subroutine2'
664 This is probably an error introduced by a recent programming change.
665 Perl::Tidy.pm reports VERSION='$VERSION'.
666 ==============================================================================
669 # This return is to keep Perl-Critic from complaining.
673 # extract various dump parameters
674 my $dump_options_type = $input_hash{'dump_options_type'};
675 my $dump_options = $get_hash_ref->('dump_options');
676 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
677 my $dump_options_category = $get_hash_ref->('dump_options_category');
678 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
679 my $dump_options_range = $get_hash_ref->('dump_options_range');
681 # validate dump_options_type
682 if ( defined($dump_options) ) {
683 unless ( defined($dump_options_type) ) {
684 $dump_options_type = 'perltidyrc';
686 if ( $dump_options_type ne 'perltidyrc'
687 && $dump_options_type ne 'full' )
690 ------------------------------------------------------------------------
691 Please check value of -dump_options_type in call to perltidy;
692 saw: '$dump_options_type'
693 expecting: 'perltidyrc' or 'full'
694 ------------------------------------------------------------------------
700 $dump_options_type = EMPTY_STRING;
703 if ($user_formatter) {
705 # if the user defines a formatter, there is no output stream,
706 # but we need a null stream to keep coding simple
707 $destination_stream = Perl::Tidy::DevNull->new();
710 # see if ARGV is overridden
711 if ( defined($argv) ) {
713 my $rargv = ref $argv;
714 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
718 if ( $rargv eq 'ARRAY' ) {
723 ------------------------------------------------------------------------
724 Please check value of -argv in call to perltidy;
725 it must be a string or ref to ARRAY but is: $rargv
726 ------------------------------------------------------------------------
733 my ( $rargv_str, $msg ) = parse_args($argv);
736 Error parsing this string passed to to perltidy with 'argv':
740 @ARGV = @{$rargv_str};
744 # These string refs will hold any warnings and error messages to be written
745 # to the logfile object when it eventually gets created.
746 my $rpending_complaint;
747 ${$rpending_complaint} = EMPTY_STRING;
749 my $rpending_logfile_message;
750 ${$rpending_logfile_message} = EMPTY_STRING;
752 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
754 # VMS file names are restricted to a 40.40 format, so we append _tdy
755 # instead of .tdy, etc. (but see also sub check_vms_filename)
758 if ( $OSNAME eq 'VMS' ) {
764 $dot_pattern = '\.'; # must escape for use in regex
766 $self->[_file_extension_separator_] = $dot;
768 #-------------------------
769 # get command line options
770 #-------------------------
771 my ( $rOpts, $config_file, $rraw_options, $roption_string,
772 $rexpansion, $roption_category, $roption_range )
773 = process_command_line(
774 $perltidyrc_stream, $is_Windows, $Windows_type,
775 $rpending_complaint, $dump_options_type,
778 # Only filenames should remain in @ARGV
779 my @Arg_files = @ARGV;
781 $self->[_rOpts_] = $rOpts;
784 grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
785 $self->[_saw_pbp_] = $saw_pbp;
787 #------------------------------------
788 # Handle requests to dump information
789 #------------------------------------
791 # return or exit immediately after all dumps
794 # Getopt parameters and their flags
795 if ( defined($dump_getopt_flags) ) {
797 foreach my $op ( @{$roption_string} ) {
799 my $flag = EMPTY_STRING;
806 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
810 $dump_getopt_flags->{$opt} = $flag;
814 if ( defined($dump_options_category) ) {
816 %{$dump_options_category} = %{$roption_category};
819 if ( defined($dump_options_range) ) {
821 %{$dump_options_range} = %{$roption_range};
824 if ( defined($dump_abbreviations) ) {
826 %{$dump_abbreviations} = %{$rexpansion};
829 if ( defined($dump_options) ) {
831 %{$dump_options} = %{$rOpts};
834 Exit(0) if ($quit_now);
836 # make printable string of options for this run as possible diagnostic
837 my $readable_options = readable_options( $rOpts, $roption_string );
839 # dump from command line
840 if ( $rOpts->{'dump-options'} ) {
841 print STDOUT $readable_options;
845 #----------------------------------------
846 # check parameters and their interactions
847 #----------------------------------------
849 check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
850 $self->[_tabsize_] = $tabsize;
852 if ($user_formatter) {
853 $rOpts->{'format'} = 'user';
856 # there must be one entry here for every possible format
857 my %default_file_extension = (
860 user => EMPTY_STRING,
863 $rstatus->{'opt_format'} = $rOpts->{'format'};
864 $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
865 $rstatus->{'opt_encode_output'} =
866 $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
868 # be sure we have a valid output format
869 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
870 my $formats = join SPACE,
871 sort map { "'" . $_ . "'" } keys %default_file_extension;
872 my $fmt = $rOpts->{'format'};
873 Die("-format='$fmt' but must be one of: $formats\n");
876 my $output_extension =
877 $self->make_file_extension( $rOpts->{'output-file-extension'},
878 $default_file_extension{ $rOpts->{'format'} } );
880 # get parameters associated with the -b option
881 my ( $in_place_modify, $backup_extension, $delete_backup ) =
882 $self->check_in_place_modify( $source_stream, $destination_stream );
884 Perl::Tidy::Formatter::check_options($rOpts);
885 Perl::Tidy::Tokenizer::check_options($rOpts);
886 Perl::Tidy::VerticalAligner::check_options($rOpts);
887 if ( $rOpts->{'format'} eq 'html' ) {
888 Perl::Tidy::HtmlWriter->check_options($rOpts);
891 # make the pattern of file extensions that we shouldn't touch
892 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
893 if ($output_extension) {
894 my $ext = quotemeta($output_extension);
895 $forbidden_file_extensions .= "|$ext";
897 if ( $in_place_modify && $backup_extension ) {
898 my $ext = quotemeta($backup_extension);
899 $forbidden_file_extensions .= "|$ext";
901 $forbidden_file_extensions .= ')$';
903 # Create a diagnostics object if requested;
904 # This is only useful for code development
905 my $diagnostics_object = undef;
906 if ( $rOpts->{'DIAGNOSTICS'} ) {
907 $diagnostics_object = Perl::Tidy::Diagnostics->new();
910 # no filenames should be given if input is from an array
911 if ($source_stream) {
912 if ( @Arg_files > 0 ) {
914 "You may not specify any filenames when a source array is given\n"
918 # we'll stuff the source array into Arg_files
919 unshift( @Arg_files, $source_stream );
921 # No special treatment for source stream which is a filename.
922 # This will enable checks for binary files and other bad stuff.
923 $source_stream = undef unless ref($source_stream);
926 # use stdin by default if no source array and no args
928 unshift( @Arg_files, '-' ) unless @Arg_files;
931 # Flag for loading module Unicode::GCString for evaluating text width:
932 # undef = ok to use but not yet loaded
933 # 0 = do not use; failed to load or not wanted
934 # 1 = successfully loaded and ok to use
935 # The module is not actually loaded unless/until it is needed
936 if ( !$rOpts->{'use-unicode-gcstring'} ) {
937 $loaded_unicode_gcstring = 0;
940 # Remove duplicate filenames. Otherwise, for example if the user entered
941 # perltidy -b myfile.pl myfile.pl
942 # the backup version of the original would be lost.
943 if ( @Arg_files > 1 ) {
945 @Arg_files = grep { !$seen{$_}++ } @Arg_files;
948 # If requested, process in order of increasing file size
949 # This can significantly reduce perl's virtual memory usage during testing.
950 if ( @Arg_files > 1 && $rOpts->{'file-size-order'} ) {
953 sort { $a->[1] <=> $b->[1] }
954 map { [ $_, -e $_ ? -s $_ : 0 ] } @Arg_files;
957 my $logfile_header = make_logfile_header( $rOpts, $config_file,
958 $rraw_options, $Windows_type, $readable_options, );
960 # Store some values needed by lower level routines
961 $self->[_diagnostics_object_] = $diagnostics_object;
962 $self->[_postfilter_] = $postfilter;
963 $self->[_prefilter_] = $prefilter;
964 $self->[_user_formatter_] = $user_formatter;
966 #--------------------------
967 # loop to process all files
968 #--------------------------
969 $self->process_all_files(
976 $forbidden_file_extensions,
984 $rpending_logfile_message,
992 # Fix for RT #130297: return a true value if anything was written to the
993 # standard error output, even non-fatal warning messages, otherwise return
996 # These exit codes are returned:
997 # 0 = perltidy ran to completion with no errors
998 # 1 = perltidy could not run to completion due to errors
999 # 2 = perltidy ran to completion with error messages
1001 # Note that if perltidy is run with multiple files, any single file with
1002 # errors or warnings will write a line like
1003 # '## Please see file testing.t.ERR'
1004 # to standard output for each file with errors, so the flag will be true,
1005 # even if only some of the multiple files may have had errors.
1008 my $ret = $Warn_count ? 2 : 0;
1009 return wantarray ? ( $ret, $rstatus ) : $ret;
1012 return wantarray ? ( 1, $rstatus ) : 1;
1014 } ## end sub perltidy
1016 sub make_file_extension {
1018 # Make a file extension, adding any leading '.' if necessary.
1019 # (the '.' may actually be an '_' under VMS).
1020 my ( $self, $extension, $default ) = @_;
1022 # '$extension' is the first choice (usually a user entry)
1023 # '$default' is a backup extension
1025 $extension = EMPTY_STRING unless defined($extension);
1026 $extension =~ s/^\s+//;
1027 $extension =~ s/\s+$//;
1029 # Use default extension if nothing remains of the first choice
1031 if ( length($extension) == 0 ) {
1032 $extension = $default;
1033 $extension = EMPTY_STRING unless defined($extension);
1034 $extension =~ s/^\s+//;
1035 $extension =~ s/\s+$//;
1038 # Only extensions with these leading characters get a '.'
1039 # This rule gives the user some freedom.
1040 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
1041 my $dot = $self->[_file_extension_separator_];
1042 $extension = $dot . $extension;
1045 } ## end sub make_file_extension
1047 sub check_in_place_modify {
1049 my ( $self, $source_stream, $destination_stream ) = @_;
1051 # get parameters associated with the -b option
1052 my $rOpts = $self->[_rOpts_];
1054 # check for -b option;
1055 # silently ignore unless beautify mode
1056 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
1057 && $rOpts->{'format'} eq 'tidy';
1059 my ( $backup_extension, $delete_backup );
1061 # Turn off -b with warnings in case of conflicts with other options.
1062 # NOTE: Do this silently, without warnings, if there is a source or
1063 # destination stream, or standard output is used. This is because the -b
1064 # flag may have been in a .perltidyrc file and warnings break
1065 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
1066 if ($in_place_modify) {
1067 if ( $rOpts->{'standard-output'}
1068 || $destination_stream
1069 || ref $source_stream
1070 || $rOpts->{'outfile'}
1071 || defined( $rOpts->{'output-path'} ) )
1073 $in_place_modify = 0;
1077 if ($in_place_modify) {
1079 # If the backup extension contains a / character then the backup should
1080 # be deleted when the -b option is used. On older versions of
1081 # perltidy this will generate an error message due to an illegal
1084 # A backup file will still be generated but will be deleted
1085 # at the end. If -bext='/' then this extension will be
1086 # the default 'bak'. Otherwise it will be whatever characters
1087 # remains after all '/' characters are removed. For example:
1088 # -bext extension slashes
1090 # '/delete' delete 1
1091 # 'delete/' delete 1
1092 # '/dev/null' devnull 2 (Currently not allowed)
1093 my $bext = $rOpts->{'backup-file-extension'};
1094 $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
1096 # At present only one forward slash is allowed. In the future multiple
1097 # slashes may be allowed to allow for other options
1098 if ( $delete_backup > 1 ) {
1099 Die("-bext=$bext contains more than one '/'\n");
1103 $self->make_file_extension( $rOpts->{'backup-file-extension'},
1107 my $backup_method = $rOpts->{'backup-method'};
1108 if ( defined($backup_method)
1109 && $backup_method ne 'copy'
1110 && $backup_method ne 'move' )
1113 "Unexpected --backup-method='$backup_method'; must be one of: 'move', 'copy'\n"
1117 return ( $in_place_modify, $backup_extension, $delete_backup );
1120 sub backup_method_copy {
1122 my ( $self, $input_file, $output_file, $backup_extension, $delete_backup )
1125 # Handle the -b (--backup-and-modify-in-place) option with -bm='copy':
1126 # - First copy $input file to $backup_name.
1127 # - Then open input file and rewrite with contents of $output_file
1128 # - Then delete the backup if requested
1131 # - Die immediately on any error.
1132 # - $output_file is actually an ARRAY ref
1134 my $backup_file = $input_file . $backup_extension;
1136 unless ( -f $input_file ) {
1138 # no real file to backup ..
1139 # This shouldn't happen because of numerous preliminary checks
1141 "problem with -b backing up input file '$input_file': not a file\n"
1145 if ( -f $backup_file ) {
1146 unlink($backup_file)
1148 "unable to remove previous '$backup_file' for -b option; check permissions: $ERRNO\n"
1152 # Copy input file to backup
1153 File::Copy::copy( $input_file, $backup_file )
1154 or Die("File::Copy failed trying to backup source: $ERRNO");
1156 # set permissions of the backup file to match the input file
1157 my @input_file_stat = stat($input_file);
1158 my $in_place_modify = 1;
1159 $self->set_output_file_permissions( $backup_file, \@input_file_stat,
1162 # Open the original input file for writing ... opening with ">" will
1163 # truncate the existing data.
1164 open( my $fout, ">", $input_file )
1166 "problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
1169 if ( $self->[_is_encoded_data_] ) {
1170 binmode $fout, ":raw:encoding(UTF-8)";
1173 # Now copy the formatted output to it..
1175 # if formatted output is in an ARRAY ref (normally this is true)...
1176 if ( ref($output_file) eq 'ARRAY' ) {
1177 foreach my $line ( @{$output_file} ) {
1180 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1184 # or in a SCALAR ref (less efficient, and only used for testing)
1185 elsif ( ref($output_file) eq 'SCALAR' ) {
1186 foreach my $line ( split /^/, ${$output_file} ) {
1189 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1193 # Error if anything else ...
1194 # This can only happen if the output was changed from \@tmp_buff
1196 my $ref = ref($output_file);
1198 Programming error: unable to print to '$input_file' with -b option:
1199 unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
1204 or Die("cannot close '$input_file' with -b option: $OS_ERROR\n");
1206 # Set permissions of the output file to match the input file. This is
1207 # necessary even if the inode remains unchanged because suid/sgid bits may
1209 $self->set_output_file_permissions( $input_file, \@input_file_stat,
1212 #---------------------------------------------------------
1213 # remove the original file for in-place modify as follows:
1214 # $delete_backup=0 never
1215 # $delete_backup=1 only if no errors
1216 # $delete_backup>1 always : NOT ALLOWED, too risky
1217 #---------------------------------------------------------
1218 if ( $delete_backup && -f $backup_file ) {
1220 # Currently, $delete_backup may only be 1. But if a future update
1221 # allows a value > 1, then reduce it to 1 if there were warnings.
1222 if ( $delete_backup > 1
1223 && $self->[_logger_object_]->get_warning_count() )
1228 # As an added safety precaution, do not delete the source file
1229 # if its size has dropped from positive to zero, since this
1230 # could indicate a disaster of some kind, including a hardware
1231 # failure. Actually, this could happen if you had a file of
1232 # all comments (or pod) and deleted everything with -dac (-dap)
1234 if ( !-s $input_file && -s $backup_file && $delete_backup == 1 ) {
1236 "output file '$input_file' missing or zero length; original '$backup_file' not deleted\n"
1240 unlink($backup_file)
1242 "unable to remove backup file '$backup_file' for -b option; check permissions: $ERRNO\n"
1247 # Verify that inode is unchanged during development
1249 my @output_file_stat = stat($input_file);
1250 my $inode_input = $input_file_stat[1];
1251 my $inode_output = $output_file_stat[1];
1252 if ( $inode_input != $inode_output ) {
1254 inode changed with -bm=copy for file '$input_file': inode_input=$inode_input inode_output=$inode_output
1260 } ## end sub backup_method_copy
1262 sub backup_method_move {
1264 my ( $self, $input_file, $output_file, $backup_extension, $delete_backup )
1267 # Handle the -b (--backup-and-modify-in-place) option with -bm='move':
1268 # - First move $input file to $backup_name.
1269 # - Then copy $output_file to $input_file.
1270 # - Then delete the backup if requested
1273 # - Die immediately on any error.
1274 # - $output_file is actually an ARRAY ref
1275 # - $input_file permissions will be set by sub set_output_file_permissions
1277 my $backup_name = $input_file . $backup_extension;
1279 unless ( -f $input_file ) {
1281 # oh, oh, no real file to backup ..
1282 # shouldn't happen because of numerous preliminary checks
1284 "problem with -b backing up input file '$input_file': not a file\n"
1287 if ( -f $backup_name ) {
1288 unlink($backup_name)
1290 "unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
1294 my @input_file_stat = stat($input_file);
1296 # backup the input file
1297 # we use copy for symlinks, move for regular files
1298 if ( -l $input_file ) {
1299 File::Copy::copy( $input_file, $backup_name )
1300 or Die("File::Copy failed trying to backup source: $ERRNO");
1303 rename( $input_file, $backup_name )
1305 "problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
1309 # Open a file with the original input file name for writing ...
1310 my $is_encoded_data = $self->[_is_encoded_data_];
1311 my ( $fout, $iname ) =
1312 Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
1315 "problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
1319 # Now copy the formatted output to it..
1321 # if formatted output is in an ARRAY ref ...
1322 if ( ref($output_file) eq 'ARRAY' ) {
1323 foreach my $line ( @{$output_file} ) {
1326 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1330 # or in a SCALAR ref (less efficient, for testing only)
1331 elsif ( ref($output_file) eq 'SCALAR' ) {
1332 foreach my $line ( split /^/, ${$output_file} ) {
1335 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1339 # Error if anything else ...
1340 # This can only happen if the output was changed from \@tmp_buff
1342 my $ref = ref($output_file);
1344 Programming error: unable to print to '$input_file' with -b option:
1345 unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
1350 or Die("cannot close '$input_file' with -b option: $OS_ERROR\n");
1352 # set permissions of the output file to match the input file
1353 my $in_place_modify = 1;
1354 $self->set_output_file_permissions( $input_file, \@input_file_stat,
1357 #---------------------------------------------------------
1358 # remove the original file for in-place modify as follows:
1359 # $delete_backup=0 never
1360 # $delete_backup=1 only if no errors
1361 # $delete_backup>1 always : NOT ALLOWED, too risky
1362 #---------------------------------------------------------
1363 if ( $delete_backup && -f $backup_name ) {
1365 # Currently, $delete_backup may only be 1. But if a future update
1366 # allows a value > 1, then reduce it to 1 if there were warnings.
1367 if ( $delete_backup > 1
1368 && $self->[_logger_object_]->get_warning_count() )
1373 # As an added safety precaution, do not delete the source file
1374 # if its size has dropped from positive to zero, since this
1375 # could indicate a disaster of some kind, including a hardware
1376 # failure. Actually, this could happen if you had a file of
1377 # all comments (or pod) and deleted everything with -dac (-dap)
1379 if ( !-s $input_file && -s $backup_name && $delete_backup == 1 ) {
1381 "output file '$input_file' missing or zero length; original '$backup_name' not deleted\n"
1385 unlink($backup_name)
1387 "unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
1394 } ## end sub backup_method_move
1396 sub set_output_file_permissions {
1398 my ( $self, $output_file, $rinput_file_stat, $in_place_modify ) = @_;
1401 # $output_file = the file whose permissions we will set
1402 # $rinput_file_stat = the result of stat($input_file)
1403 # $in_place_modify = true if --backup-and-modify-in-place is set
1405 my ( $mode_i, $uid_i, $gid_i ) = @{$rinput_file_stat}[ 2, 4, 5 ];
1406 my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
1407 my $input_file_permissions = $mode_i & oct(7777);
1408 my $output_file_permissions = $input_file_permissions;
1410 #rt128477: avoid inconsistent owner/group and suid/sgid
1411 if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
1413 # try to change owner and group to match input file if
1414 # in -b mode. Note: chown returns number of files
1415 # successfully changed.
1416 if ( $in_place_modify
1417 && chown( $uid_i, $gid_i, $output_file ) )
1419 # owner/group successfully changed
1423 # owner or group differ: do not copy suid and sgid
1424 $output_file_permissions = $mode_i & oct(777);
1425 if ( $input_file_permissions != $output_file_permissions ) {
1427 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
1433 # Mark the output file for rw unless we are in -b mode.
1434 # Explanation: perltidy does not unlink existing output
1435 # files before writing to them, for safety. If a
1436 # designated output file exists and is not writable,
1437 # perltidy will halt. This can prevent a data loss if a
1438 # user accidentally enters "perltidy infile -o
1439 # important_ro_file", or "perltidy infile -st
1440 # >important_ro_file". But it also means that perltidy can
1441 # get locked out of rerunning unless it marks its own
1442 # output files writable. The alternative, of always
1443 # unlinking the designated output file, is less safe and
1444 # not always possible, except in -b mode, where there is an
1445 # assumption that a previous backup can be unlinked even if
1447 if ( !$in_place_modify ) {
1448 $output_file_permissions |= oct(600);
1451 if ( !chmod( $output_file_permissions, $output_file ) ) {
1453 # couldn't change file permissions
1454 my $operm = sprintf "%04o", $output_file_permissions;
1456 "Unable to set permissions for output file '$output_file' to $operm\n"
1460 } ## end sub set_output_file_permissions
1462 sub get_decoded_string_buffer {
1463 my ( $self, $input_file, $display_name, $rpending_logfile_message ) = @_;
1465 # Decode the input buffer if necessary or requested
1468 # $input_file = the input file or stream
1469 # $display_name = its name to use in error messages
1472 # $buf = string buffer with input, decoded from utf8 if necessary
1473 # $is_encoded_data = true if $buf is decoded from utf8
1474 # $decoded_input_as = true if perltidy decoded input buf
1475 # $encoding_log_message = messages for log file,
1476 # $length_function = function to use for measuring string width
1478 # Return nothing on any error; this is a signal to skip this file
1480 my $rOpts = $self->[_rOpts_];
1482 my $source_object = Perl::Tidy::LineSource->new(
1483 input_file => $input_file,
1487 # return nothing if error
1488 return unless ($source_object);
1490 my $buf = EMPTY_STRING;
1491 while ( my $line = $source_object->get_line() ) {
1495 my $encoding_in = EMPTY_STRING;
1496 my $rOpts_character_encoding = $rOpts->{'character-encoding'};
1497 my $encoding_log_message;
1498 my $decoded_input_as = EMPTY_STRING;
1499 $rstatus->{'char_mode_source'} = 0;
1501 # Case 1: If Perl is already in a character-oriented mode for this
1502 # string rather than a byte-oriented mode. Normally, this happens if
1503 # the caller has decoded a utf8 string before calling perltidy. But it
1504 # could also happen if the user has done some unusual manipulations of
1505 # the source. In any case, we will not attempt to decode it because
1506 # that could result in an output string in a different mode.
1507 if ( is_char_mode($buf) ) {
1508 $encoding_in = "utf8";
1509 $rstatus->{'char_mode_source'} = 1;
1512 # Case 2. No input stream encoding requested. This is appropriate
1513 # for single-byte encodings like ascii, latin-1, etc
1514 elsif ( !$rOpts_character_encoding
1515 || $rOpts_character_encoding eq 'none' )
1521 # Case 3. guess input stream encoding if requested
1522 elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
1524 # The guessing strategy is simple: use Encode::Guess to guess
1525 # an encoding. If and only if the guess is utf8, try decoding and
1526 # use it if successful. Otherwise, we proceed assuming the
1527 # characters are encoded as single bytes (same as if 'none' had
1528 # been specified as the encoding).
1530 # In testing I have found that including additional guess 'suspect'
1531 # encodings sometimes works but can sometimes lead to disaster by
1532 # using an incorrect decoding. The user can always specify a
1533 # specific input encoding.
1536 my $decoder = guess_encoding( $buf_in, 'utf8' );
1537 if ( ref($decoder) ) {
1538 $encoding_in = $decoder->name;
1539 if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
1540 $encoding_in = EMPTY_STRING;
1542 $encoding_log_message .= <<EOM;
1543 Guessed encoding '$encoding_in' is not utf8; no encoding will be used
1548 if ( !eval { $buf = $decoder->decode($buf_in); 1 } ) {
1550 $encoding_log_message .= <<EOM;
1551 Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
1554 # Note that a guess failed, but keep going
1555 # This warning can eventually be removed
1557 "file: $display_name: bad guess to decode source as $encoding_in\n"
1559 $encoding_in = EMPTY_STRING;
1563 $encoding_log_message .= <<EOM;
1564 Guessed encoding '$encoding_in' successfully decoded
1566 $decoded_input_as = $encoding_in;
1571 $encoding_log_message .= <<EOM;
1572 Does not look like utf8 encoded text so processing as raw bytes
1577 # Case 4. Decode with a specific encoding
1579 $encoding_in = $rOpts_character_encoding;
1582 $buf = Encode::decode( $encoding_in, $buf,
1583 Encode::FB_CROAK | Encode::LEAVE_SRC );
1589 # Quit if we cannot decode by the requested encoding;
1590 # Something is not right.
1592 "skipping file: $display_name: Unable to decode source as $encoding_in\n"
1595 # return nothing on error
1599 $encoding_log_message .= <<EOM;
1600 Specified encoding '$encoding_in' successfully decoded
1602 $decoded_input_as = $encoding_in;
1606 # Set the encoding to be used for all further i/o: If we have
1607 # decoded the data with any format, then we must continue to
1608 # read and write it as encoded data, and we will normalize these
1609 # operations with utf8. If we have not decoded the data, then
1610 # we must not treat it as encoded data.
1611 my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
1612 $self->[_is_encoded_data_] = $is_encoded_data;
1614 # Delete any Byte Order Mark (BOM), which can cause trouble
1615 if ($is_encoded_data) {
1616 $buf =~ s/^\x{FEFF}//;
1619 $rstatus->{'input_name'} = $display_name;
1620 $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
1621 $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
1622 $rstatus->{'input_decoded_as'} = $decoded_input_as;
1624 # Define the function to determine the display width of character
1626 my $length_function = sub { return length( $_[0] ) };
1627 if ($is_encoded_data) {
1629 # Try to load Unicode::GCString for defining text display width, if
1630 # requested, when the first encoded file is encountered
1631 if ( !defined($loaded_unicode_gcstring) ) {
1632 if ( eval { require Unicode::GCString; 1 } ) {
1633 $loaded_unicode_gcstring = 1;
1636 $loaded_unicode_gcstring = 0;
1637 if ( $rOpts->{'use-unicode-gcstring'} ) {
1639 ----------------------
1640 Unable to load Unicode::GCString: $EVAL_ERROR
1641 Processing continues but some vertical alignment may be poor
1642 To prevent this warning message, you can either:
1643 - install module Unicode::GCString, or
1644 - remove '--use-unicode-gcstring' or '-gcs' from your perltidyrc or command line
1645 ----------------------
1650 if ($loaded_unicode_gcstring) {
1651 $length_function = sub {
1652 return Unicode::GCString->new( $_[0] )->columns;
1654 $encoding_log_message .= <<EOM;
1655 Using 'Unicode::GCString' to measure horizontal character widths
1657 $rstatus->{'gcs_used'} = 1;
1664 $encoding_log_message,
1668 } ## end sub get_decoded_string_buffer
1670 sub process_all_files {
1679 $forbidden_file_extensions,
1685 $rpending_complaint,
1686 $rpending_logfile_message,
1690 # This routine is the main loop to process all files.
1691 # Total formatting is done with these layers of subroutines:
1692 # perltidy - main routine; checks run parameters
1693 # *process_all_files - main loop to process all files; *THIS LAYER
1694 # process_filter_layer - do any pre and post processing;
1695 # process_iteration_layer - handle any iterations on formatting
1696 # process_single_case - solves one formatting problem
1698 my $rOpts = $self->[_rOpts_];
1699 my $dot = $self->[_file_extension_separator_];
1700 my $diagnostics_object = $self->[_diagnostics_object_];
1702 my $destination_stream = $rinput_hash->{'destination'};
1703 my $errorfile_stream = $rinput_hash->{'errorfile'};
1704 my $logfile_stream = $rinput_hash->{'logfile'};
1705 my $teefile_stream = $rinput_hash->{'teefile'};
1706 my $debugfile_stream = $rinput_hash->{'debugfile'};
1707 my $source_stream = $rinput_hash->{'source'};
1708 my $stderr_stream = $rinput_hash->{'stderr'};
1710 my $number_of_files = @{$rfiles};
1711 while ( my $input_file = shift @{$rfiles} ) {
1714 my @input_file_stat;
1717 #--------------------------
1718 # prepare this input stream
1719 #--------------------------
1720 if ($source_stream) {
1721 $fileroot = "perltidy";
1722 $display_name = "<source_stream>";
1724 # If the source is from an array or string, then .LOG output
1725 # is only possible if a logfile stream is specified. This prevents
1726 # unexpected perltidy.LOG files.
1727 if ( !defined($logfile_stream) ) {
1728 $logfile_stream = Perl::Tidy::DevNull->new();
1730 # Likewise for .TEE and .DEBUG output
1732 if ( !defined($teefile_stream) ) {
1733 $teefile_stream = Perl::Tidy::DevNull->new();
1735 if ( !defined($debugfile_stream) ) {
1736 $debugfile_stream = Perl::Tidy::DevNull->new();
1739 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
1740 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
1741 $display_name = "<stdin>";
1742 $in_place_modify = 0;
1745 $fileroot = $input_file;
1746 $display_name = $input_file;
1747 unless ( -e $input_file ) {
1749 # file doesn't exist - check for a file glob
1750 if ( $input_file =~ /([\?\*\[\{])/ ) {
1752 # Windows shell may not remove quotes, so do it
1753 my $input_file = $input_file;
1754 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
1755 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
1756 my $pattern = fileglob_to_re($input_file);
1758 if ( opendir( $dh, './' ) ) {
1760 grep { /$pattern/ && !-d } readdir($dh);
1762 next unless (@files);
1763 unshift @{$rfiles}, @files;
1767 Warn("skipping file: '$input_file': no matches found\n");
1771 unless ( -f $input_file ) {
1772 Warn("skipping file: $input_file: not a regular file\n");
1776 # As a safety precaution, skip zero length files.
1777 # If for example a source file got clobbered somehow,
1778 # the old .tdy or .bak files might still exist so we
1779 # shouldn't overwrite them with zero length files.
1780 unless ( -s $input_file ) {
1781 Warn("skipping file: $input_file: Zero size\n");
1785 # And avoid formatting extremely large files. Since perltidy reads
1786 # files into memory, trying to process an extremely large file
1787 # could cause system problems.
1788 my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 );
1789 if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) {
1790 $size_in_mb = sprintf( "%0.1f", $size_in_mb );
1792 "skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n"
1797 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
1798 Warn("skipping file: $input_file: Non-text (override with -f)\n"
1803 # Input file must be writable for -b -bm='copy'. We must catch
1804 # this early to prevent encountering trouble after unlinking the
1806 if ( $in_place_modify && !-w $input_file ) {
1807 my $backup_method = $rOpts->{'backup-method'};
1808 if ( defined($backup_method) && $backup_method eq 'copy' ) {
1810 "skipping file '$input_file' for -b option: file reported as non-writable\n";
1815 # we should have a valid filename now
1816 $fileroot = $input_file;
1817 @input_file_stat = stat($input_file);
1819 if ( $OSNAME eq 'VMS' ) {
1820 ( $fileroot, $dot ) = check_vms_filename($fileroot);
1821 $self->[_file_extension_separator_] = $dot;
1824 # add option to change path here
1825 if ( defined( $rOpts->{'output-path'} ) ) {
1827 my ( $base, $old_path ) = fileparse($fileroot);
1828 my $new_path = $rOpts->{'output-path'};
1829 unless ( -d $new_path ) {
1830 unless ( mkdir $new_path, 0777 ) {
1831 Die("unable to create directory $new_path: $ERRNO\n");
1834 my $path = $new_path;
1835 $fileroot = catfile( $path, $base );
1836 unless ($fileroot) {
1838 ------------------------------------------------------------------------
1839 Problem combining $new_path and $base to make a filename; check -opath
1840 ------------------------------------------------------------------------
1846 # Skip files with same extension as the output files because
1847 # this can lead to a messy situation with files like
1848 # script.tdy.tdy.tdy ... or worse problems ... when you
1849 # rerun perltidy over and over with wildcard input.
1852 && ( $input_file =~ /$forbidden_file_extensions/
1853 || $input_file eq 'DIAGNOSTICS' )
1856 Warn("skipping file: $input_file: wrong extension\n");
1860 # copy source to a string buffer, decoding from utf8 if necessary
1865 $encoding_log_message,
1868 ) = $self->get_decoded_string_buffer( $input_file, $display_name,
1869 $rpending_logfile_message );
1871 # Skip this file on any error
1872 next if ( !defined($buf) );
1874 # Register this file name with the Diagnostics package, if any.
1875 $diagnostics_object->set_input_file($input_file)
1876 if $diagnostics_object;
1878 # OK: the (possibly decoded) input is now in string $buf. We just need
1879 # to to prepare the output and error logger before formatting it.
1881 #--------------------------
1882 # prepare the output stream
1883 #--------------------------
1884 my $output_file = undef;
1885 my $output_name = EMPTY_STRING;
1886 my $actual_output_extension;
1888 if ( $rOpts->{'outfile'} ) {
1890 if ( $number_of_files <= 1 ) {
1892 if ( $rOpts->{'standard-output'} ) {
1893 my $saw_pbp = $self->[_saw_pbp_];
1894 my $msg = "You may not use -o and -st together";
1895 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1898 elsif ($destination_stream) {
1900 "You may not specify a destination array and -o together\n"
1903 elsif ( defined( $rOpts->{'output-path'} ) ) {
1904 Die("You may not specify -o and -opath together\n");
1906 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
1907 Die("You may not specify -o and -oext together\n");
1909 $output_file = $rOpts->{outfile};
1910 $output_name = $output_file;
1912 # make sure user gives a file name after -o
1913 if ( $output_file =~ /^-/ ) {
1914 Die("You must specify a valid filename after -o\n");
1917 # do not overwrite input file with -o
1918 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
1919 Die("Use 'perltidy -b $input_file' to modify in-place\n");
1923 Die("You may not use -o with more than one input file\n");
1926 elsif ( $rOpts->{'standard-output'} ) {
1927 if ($destination_stream) {
1928 my $saw_pbp = $self->[_saw_pbp_];
1930 "You may not specify a destination array and -st together\n";
1931 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1935 $output_name = "<stdout>";
1937 if ( $number_of_files <= 1 ) {
1940 Die("You may not use -st with more than one input file\n");
1943 elsif ($destination_stream) {
1945 $output_file = $destination_stream;
1946 $output_name = "<destination_stream>";
1948 elsif ($source_stream) { # source but no destination goes to stdout
1950 $output_name = "<stdout>";
1952 elsif ( $input_file eq '-' ) {
1954 $output_name = "<stdout>";
1957 if ($in_place_modify) {
1959 # Send output to a temporary array buffer. This will
1960 # allow efficient copying back to the input by
1961 # sub backup_and_modify_in_place, below.
1963 $output_file = \@tmp_buff;
1964 $output_name = $display_name;
1967 $actual_output_extension = $output_extension;
1968 $output_file = $fileroot . $output_extension;
1969 $output_name = $output_file;
1973 $rstatus->{'file_count'} += 1;
1974 $rstatus->{'output_name'} = $output_name;
1975 $rstatus->{'iteration_count'} = 0;
1976 $rstatus->{'converged'} = 0;
1978 #------------------------------------------
1979 # initialize the error logger for this file
1980 #------------------------------------------
1981 my $warning_file = $fileroot . $dot . "ERR";
1982 if ($errorfile_stream) { $warning_file = $errorfile_stream }
1983 my $log_file = $fileroot . $dot . "LOG";
1984 if ($logfile_stream) { $log_file = $logfile_stream }
1986 my $logger_object = Perl::Tidy::Logger->new(
1988 log_file => $log_file,
1989 warning_file => $warning_file,
1990 fh_stderr => $fh_stderr,
1991 display_name => $display_name,
1992 is_encoded_data => $is_encoded_data,
1994 $logger_object->write_logfile_entry($logfile_header);
1995 $logger_object->write_logfile_entry($encoding_log_message)
1996 if $encoding_log_message;
1998 # Now we can add any pending messages to the log
1999 if ( ${$rpending_logfile_message} ) {
2000 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
2002 if ( ${$rpending_complaint} ) {
2003 $logger_object->complain( ${$rpending_complaint} );
2006 my $line_separator = $rOpts->{'output-line-ending'};
2007 if ( $rOpts->{'preserve-line-endings'} ) {
2008 $line_separator = find_input_line_ending($input_file);
2010 $line_separator = "\n" unless defined($line_separator);
2012 # additional parameters needed by lower level routines
2013 $self->[_actual_output_extension_] = $actual_output_extension;
2014 $self->[_debugfile_stream_] = $debugfile_stream;
2015 $self->[_decoded_input_as_] = $decoded_input_as;
2016 $self->[_destination_stream_] = $destination_stream;
2017 $self->[_display_name_] = $display_name;
2018 $self->[_fileroot_] = $fileroot;
2019 $self->[_is_encoded_data_] = $is_encoded_data;
2020 $self->[_length_function_] = $length_function;
2021 $self->[_line_separator_] = $line_separator;
2022 $self->[_logger_object_] = $logger_object;
2023 $self->[_output_file_] = $output_file;
2024 $self->[_teefile_stream_] = $teefile_stream;
2026 #----------------------------------------------------------
2027 # Do all formatting of this buffer.
2028 # Results will go to the selected output file or streams(s)
2029 #----------------------------------------------------------
2030 $self->process_filter_layer($buf);
2032 #--------------------------------------------------
2033 # Handle the -b option (backup and modify in-place)
2034 #--------------------------------------------------
2035 if ($in_place_modify) {
2037 my $backup_method = $rOpts->{'backup-method'};
2039 # Option 1, -bm='copy': uses newer version in which original is
2040 # copied to the backup and rewritten; see git #103.
2041 if ( defined($backup_method) && $backup_method eq 'copy' ) {
2042 $self->backup_method_copy(
2043 $input_file, $output_file,
2044 $backup_extension, $delete_backup
2048 # Option 2, -bm='move': uses older version, where original is moved
2049 # to the backup and formatted output goes to a new file.
2051 $self->backup_method_move(
2052 $input_file, $output_file,
2053 $backup_extension, $delete_backup
2056 $output_file = $input_file;
2059 #-------------------------------------------------------------------
2060 # Otherwise set output file ownership and permissions if appropriate
2061 #-------------------------------------------------------------------
2062 elsif ( $output_file && -f $output_file && !-l $output_file ) {
2063 if (@input_file_stat) {
2064 if ( $rOpts->{'format'} eq 'tidy' ) {
2065 $self->set_output_file_permissions( $output_file,
2066 \@input_file_stat, $in_place_modify );
2069 # else use default permissions for html and any other format
2073 $logger_object->finish()
2075 } ## end of main loop to process all files
2078 } ## end sub process_all_files
2080 sub process_filter_layer {
2082 my ( $self, $buf ) = @_;
2084 # This is the filter layer of processing.
2085 # Do all requested formatting on the string '$buf', including any
2086 # pre- and post-processing with filters.
2087 # Store the results in the selected output file(s) or stream(s).
2089 # Total formatting is done with these layers of subroutines:
2090 # perltidy - main routine; checks run parameters
2091 # process_all_files - main loop to process all files;
2092 # *process_filter_layer - do any pre and post processing; *THIS LAYER
2093 # process_iteration_layer - handle any iterations on formatting
2094 # process_single_case - solves one formatting problem
2096 # Data Flow in this layer:
2098 # -> optional prefilter operation
2099 # -> [ formatting by sub process_iteration_layer ]
2100 # -> ( optional postfilter_buffer for postfilter, other operations )
2101 # -> ( optional destination_buffer for encoding )
2102 # -> final sink_object
2104 # What is done based on format type:
2105 # utf8 decoding is done for all format types
2106 # prefiltering is applied to all format types
2107 # - because it may be needed to get through the tokenizer
2108 # postfiltering is only done for format='tidy'
2109 # - might cause problems operating on html text
2110 # encoding of decoded output is only done for format='tidy'
2111 # - because html does its own encoding; user formatter does what it wants
2113 my $rOpts = $self->[_rOpts_];
2114 my $is_encoded_data = $self->[_is_encoded_data_];
2115 my $logger_object = $self->[_logger_object_];
2116 my $output_file = $self->[_output_file_];
2117 my $user_formatter = $self->[_user_formatter_];
2118 my $destination_stream = $self->[_destination_stream_];
2119 my $prefilter = $self->[_prefilter_];
2120 my $postfilter = $self->[_postfilter_];
2121 my $decoded_input_as = $self->[_decoded_input_as_];
2122 my $line_separator = $self->[_line_separator_];
2124 my $remove_terminal_newline =
2125 !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
2127 # vars for postfilter, if used
2128 my $use_postfilter_buffer;
2129 my $postfilter_buffer;
2131 # vars for destination buffer, if used
2132 my $destination_buffer;
2133 my $use_destination_buffer;
2134 my $encode_destination_buffer;
2136 # vars for iterations, if done
2139 # vars for checking assertions, if needed
2140 my $digest_input = 0;
2141 my $saved_input_buf;
2143 my $ref_destination_stream = ref($destination_stream);
2145 # Setup vars for postfilter, destination buffer, assertions and sink object
2146 # if needed. These are only used for 'tidy' formatting.
2147 if ( $rOpts->{'format'} eq 'tidy' ) {
2149 # evaluate MD5 sum of input file for assert tests before any prefilter
2150 if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
2151 $digest_input = $md5_hex->($buf);
2152 $saved_input_buf = $buf;
2155 #-----------------------
2156 # Setup postfilter buffer
2157 #-----------------------
2158 # If we need access to the output for filtering or checking assertions
2159 # before writing to its ultimate destination, then we will send it
2160 # to a temporary buffer. The variables are:
2161 # $postfilter_buffer = the buffer to capture the output
2162 # $use_postfilter_buffer = is a postfilter buffer used?
2163 # These are used below, just after iterations are made.
2164 $use_postfilter_buffer =
2166 || $remove_terminal_newline
2167 || $rOpts->{'assert-tidy'}
2168 || $rOpts->{'assert-untidy'};
2170 #-------------------------
2171 # Setup destination_buffer
2172 #-------------------------
2173 # If the final output destination is not a file, then we might need to
2174 # encode the result at the end of processing. So in this case we will
2175 # send the output to a temporary buffer.
2176 # The key variables are:
2177 # $destination_buffer - receives the formatted output
2178 # $use_destination_buffer - is $destination_buffer used?
2179 # $encode_destination_buffer - encode $destination_buffer?
2180 # These are used by sub 'copy_buffer_to_destination', below
2182 if ($ref_destination_stream) {
2183 $use_destination_buffer = 1;
2184 $output_file = \$destination_buffer;
2185 $self->[_output_file_] = $output_file;
2187 # Strings and arrays use special encoding rules
2188 if ( $ref_destination_stream eq 'SCALAR'
2189 || $ref_destination_stream eq 'ARRAY' )
2191 $encode_destination_buffer =
2192 $rOpts->{'encode-output-strings'} && $decoded_input_as;
2195 # An object with a print method will use file encoding rules
2196 elsif ( $ref_destination_stream->can('print') ) {
2197 $encode_destination_buffer = $is_encoded_data;
2201 ------------------------------------------------------------------------
2202 No 'print' method is defined for object of class '$ref_destination_stream'
2203 Please check your call to Perl::Tidy::perltidy. Trace follows.
2204 ------------------------------------------------------------------------
2209 #-------------------------------------------
2210 # Make a sink object for the iteration phase
2211 #-------------------------------------------
2212 $sink_object = Perl::Tidy::LineSink->new(
2213 output_file => $use_postfilter_buffer
2214 ? \$postfilter_buffer
2216 line_separator => $line_separator,
2217 is_encoded_data => $is_encoded_data,
2221 #-----------------------------------------------------------------------
2222 # Apply any prefilter. The prefilter is a code reference that will be
2223 # applied to the source before tokenizing. Note that we are doing this
2224 # for all format types ('tidy', 'html', 'user') because it may be needed
2225 # to avoid tokenization errors.
2226 #-----------------------------------------------------------------------
2227 $buf = $prefilter->($buf) if $prefilter;
2229 #----------------------------------------------------------------------
2230 # Format contents of string '$buf', iterating if requested.
2231 # For 'tidy', formatted result will be written to '$sink_object'
2232 # For 'html' and 'user', result goes directly to its ultimate destination.
2233 #----------------------------------------------------------------------
2234 $self->process_iteration_layer( $buf, $sink_object );
2236 #--------------------------------
2237 # Do postfilter buffer processing
2238 #--------------------------------
2239 if ($use_postfilter_buffer) {
2241 my $sink_object_post = Perl::Tidy::LineSink->new(
2242 output_file => $output_file,
2243 line_separator => $line_separator,
2244 is_encoded_data => $is_encoded_data,
2247 #----------------------------------------------------------------------
2248 # Apply any postfilter. The postfilter is a code reference that will be
2249 # applied to the source after tidying.
2250 #----------------------------------------------------------------------
2253 ? $postfilter->($postfilter_buffer)
2254 : $postfilter_buffer;
2256 # Check if file changed if requested, but only after any postfilter
2257 if ( $rOpts->{'assert-tidy'} ) {
2258 my $digest_output = $md5_hex->($buf_post);
2259 if ( $digest_output ne $digest_input ) {
2261 compare_string_buffers( $saved_input_buf, $buf_post,
2263 $logger_object->warning(<<EOM);
2264 assertion failure: '--assert-tidy' is set but output differs from input
2266 $logger_object->interrupt_logfile();
2267 $logger_object->warning( $diff_msg . "\n" );
2268 $logger_object->resume_logfile();
2272 if ( $rOpts->{'assert-untidy'} ) {
2273 my $digest_output = $md5_hex->($buf_post);
2274 if ( $digest_output eq $digest_input ) {
2275 $logger_object->warning(
2276 "assertion failure: '--assert-untidy' is set but output equals input\n"
2281 my $source_object = Perl::Tidy::LineSource->new(
2282 input_file => \$buf_post,
2286 # Copy the filtered buffer to the final destination
2287 if ( !$remove_terminal_newline ) {
2288 while ( my $line = $source_object->get_line() ) {
2289 $sink_object_post->write_line($line);
2294 # Copy the filtered buffer but remove the newline char from the
2297 while ( my $next_line = $source_object->get_line() ) {
2298 $sink_object_post->write_line($line) if ($line);
2302 $sink_object_post->set_line_separator(undef);
2304 $sink_object_post->write_line($line);
2307 $sink_object_post->close_output_file();
2308 $source_object->close_input_file();
2311 #--------------------------------------------------------
2312 # Do destination buffer processing, encoding if required.
2313 #--------------------------------------------------------
2314 if ($use_destination_buffer) {
2315 $self->copy_buffer_to_destination( $destination_buffer,
2316 $destination_stream, $encode_destination_buffer );
2320 # output went to a file in 'tidy' mode...
2321 if ( $is_encoded_data && $rOpts->{'format'} eq 'tidy' ) {
2322 $rstatus->{'output_encoded_as'} = 'UTF-8';
2326 # The final formatted result should now be in the selected output file(s)
2330 } ## end sub process_filter_layer
2332 sub process_iteration_layer {
2334 my ( $self, $buf, $sink_object ) = @_;
2336 # This is the iteration layer of processing.
2337 # Do all formatting, iterating if requested, on the source string $buf.
2338 # Output depends on format type:
2339 # For 'tidy' formatting, output goes to sink object
2340 # For 'html' formatting, output goes to the ultimate destination
2341 # For 'user' formatting, user formatter handles output
2343 # Total formatting is done with these layers of subroutines:
2344 # perltidy - main routine; checks run parameters
2345 # process_all_files - main loop to process all files;
2346 # process_filter_layer - do any pre and post processing
2347 # *process_iteration_layer - do any iterations on formatting; *THIS LAYER
2348 # process_single_case - solves one formatting problem
2350 # Data Flow in this layer:
2351 # $buf -> [ loop over iterations ] -> $sink_object
2353 # Only 'tidy' formatting can use multiple iterations.
2355 my $diagnostics_object = $self->[_diagnostics_object_];
2356 my $display_name = $self->[_display_name_];
2357 my $fileroot = $self->[_fileroot_];
2358 my $is_encoded_data = $self->[_is_encoded_data_];
2359 my $length_function = $self->[_length_function_];
2360 my $line_separator = $self->[_line_separator_];
2361 my $logger_object = $self->[_logger_object_];
2362 my $rOpts = $self->[_rOpts_];
2363 my $tabsize = $self->[_tabsize_];
2364 my $user_formatter = $self->[_user_formatter_];
2366 # create a source object for the buffer
2367 my $source_object = Perl::Tidy::LineSource->new(
2368 input_file => \$buf,
2372 # make a debugger object if requested
2373 my $debugger_object;
2374 if ( $rOpts->{DEBUG} ) {
2375 my $debug_file = $self->[_debugfile_stream_]
2376 || $fileroot . $self->make_file_extension('DEBUG');
2378 Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data );
2381 # make a tee file handle if requested
2383 if ( $rOpts->{'tee-pod'}
2384 || $rOpts->{'tee-block-comments'}
2385 || $rOpts->{'tee-side-comments'} )
2387 my $tee_file = $self->[_teefile_stream_]
2388 || $fileroot . $self->make_file_extension('TEE');
2389 ( $fh_tee, my $tee_filename ) =
2390 Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
2392 Warn("couldn't open TEE file $tee_file: $ERRNO\n");
2396 # vars for iterations and convergence test
2397 my $max_iterations = 1;
2398 my $convergence_log_message;
2399 my $do_convergence_test;
2402 # Only 'tidy' formatting can use multiple iterations
2403 if ( $rOpts->{'format'} eq 'tidy' ) {
2405 # check iteration count and quietly fix if necessary:
2406 # - iterations option only applies to code beautification mode
2407 # - the convergence check should stop most runs on iteration 2, and
2408 # virtually all on iteration 3. But we'll allow up to 6.
2409 $max_iterations = $rOpts->{'iterations'};
2410 if ( !defined($max_iterations)
2411 || $max_iterations <= 0 )
2413 $max_iterations = 1;
2415 elsif ( $max_iterations > 6 ) {
2416 $max_iterations = 6;
2419 # get starting MD5 sum for convergence test
2420 if ( $max_iterations > 1 ) {
2421 $do_convergence_test = 1;
2422 my $digest = $md5_hex->($buf);
2423 $saw_md5{$digest} = 0;
2427 # save objects to allow redirecting output during iterations
2428 my $sink_object_final = $sink_object;
2429 my $logger_object_final = $logger_object;
2430 my $iteration_of_formatter_convergence;
2432 #---------------------
2433 # Loop over iterations
2434 #---------------------
2435 foreach my $iter ( 1 .. $max_iterations ) {
2437 $rstatus->{'iteration_count'} += 1;
2439 # send output stream to temp buffers until last iteration
2441 if ( $iter < $max_iterations ) {
2442 $sink_object = Perl::Tidy::LineSink->new(
2443 output_file => \$sink_buffer,
2444 line_separator => $line_separator,
2445 is_encoded_data => $is_encoded_data,
2449 $sink_object = $sink_object_final;
2452 # Save logger, debugger and tee output only on pass 1 because:
2453 # (1) line number references must be to the starting
2454 # source, not an intermediate result, and
2455 # (2) we need to know if there are errors so we can stop the
2456 # iterations early if necessary.
2457 # (3) the tee option only works on first pass if comments are also
2461 $debugger_object->close_debug_file() if ($debugger_object);
2462 $fh_tee->close() if ($fh_tee);
2464 $debugger_object = undef;
2465 $logger_object = undef;
2469 #---------------------------------
2470 # create a formatter for this file
2471 #---------------------------------
2475 if ($user_formatter) {
2476 $formatter = $user_formatter;
2478 elsif ( $rOpts->{'format'} eq 'html' ) {
2480 my $html_toc_extension =
2481 $self->make_file_extension( $rOpts->{'html-toc-extension'},
2484 my $html_src_extension =
2485 $self->make_file_extension( $rOpts->{'html-src-extension'},
2488 $formatter = Perl::Tidy::HtmlWriter->new(
2489 input_file => $fileroot,
2490 html_file => $self->[_output_file_],
2491 extension => $self->[_actual_output_extension_],
2492 html_toc_extension => $html_toc_extension,
2493 html_src_extension => $html_src_extension,
2496 elsif ( $rOpts->{'format'} eq 'tidy' ) {
2497 $formatter = Perl::Tidy::Formatter->new(
2498 logger_object => $logger_object,
2499 diagnostics_object => $diagnostics_object,
2500 sink_object => $sink_object,
2501 length_function => $length_function,
2502 is_encoded_data => $is_encoded_data,
2507 Die("I don't know how to do -format=$rOpts->{'format'}\n");
2510 unless ($formatter) {
2511 Die("Unable to continue with $rOpts->{'format'} formatting\n");
2514 #-----------------------------------
2515 # create the tokenizer for this file
2516 #-----------------------------------
2517 my $tokenizer = Perl::Tidy::Tokenizer->new(
2518 source_object => $source_object,
2519 logger_object => $logger_object,
2520 debugger_object => $debugger_object,
2521 diagnostics_object => $diagnostics_object,
2522 tabsize => $tabsize,
2525 starting_level => $rOpts->{'starting-indentation-level'},
2526 indent_columns => $rOpts->{'indent-columns'},
2527 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
2528 look_for_autoloader => $rOpts->{'look-for-autoloader'},
2529 look_for_selfloader => $rOpts->{'look-for-selfloader'},
2530 trim_qw => $rOpts->{'trim-qw'},
2531 extended_syntax => $rOpts->{'extended-syntax'},
2533 continuation_indentation => $rOpts->{'continuation-indentation'},
2534 outdent_labels => $rOpts->{'outdent-labels'},
2537 #---------------------------------
2538 # do processing for this iteration
2539 #---------------------------------
2540 process_single_case( $tokenizer, $formatter );
2542 #-----------------------------------------
2543 # close the input source and report errors
2544 #-----------------------------------------
2545 $source_object->close_input_file();
2547 # see if the formatter is converged
2548 if ( $max_iterations > 1
2549 && !defined($iteration_of_formatter_convergence)
2550 && $formatter->can('get_convergence_check') )
2552 if ( $formatter->get_convergence_check() ) {
2553 $iteration_of_formatter_convergence = $iter;
2554 $rstatus->{'converged'} = 1;
2558 # line source for next iteration (if any) comes from the current
2559 # temporary output buffer
2560 if ( $iter < $max_iterations ) {
2562 $sink_object->close_output_file();
2563 $source_object = Perl::Tidy::LineSource->new(
2564 input_file => \$sink_buffer,
2568 # stop iterations if errors or converged
2569 my $stop_now = $tokenizer->report_tokenization_errors();
2570 $stop_now ||= $tokenizer->get_unexpected_error_count();
2571 my $stopping_on_error = $stop_now;
2573 $convergence_log_message = <<EOM;
2574 Stopping iterations because of severe errors.
2577 elsif ($do_convergence_test) {
2579 # stop if the formatter has converged
2580 $stop_now ||= defined($iteration_of_formatter_convergence);
2582 my $digest = $md5_hex->($sink_buffer);
2583 if ( !defined( $saw_md5{$digest} ) ) {
2584 $saw_md5{$digest} = $iter;
2588 # Deja vu, stop iterating
2590 my $iterm = $iter - 1;
2591 if ( $saw_md5{$digest} != $iterm ) {
2593 # Blinking (oscillating) between two or more stable
2594 # end states. This is unlikely to occur with normal
2595 # parameters, but it can occur in stress testing
2596 # with extreme parameter values, such as very short
2597 # maximum line lengths. We want to catch and fix
2598 # them when they happen.
2599 $rstatus->{'blinking'} = 1;
2600 $convergence_log_message = <<EOM;
2601 BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
2603 $stopping_on_error ||= $convergence_log_message;
2605 && print STDERR $convergence_log_message;
2606 $diagnostics_object->write_diagnostics(
2607 $convergence_log_message)
2608 if $diagnostics_object;
2610 # Uncomment to search for blinking states
2611 # Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" );
2615 $convergence_log_message = <<EOM;
2616 Converged. Output for iteration $iter same as for iter $iterm.
2618 $diagnostics_object->write_diagnostics(
2619 $convergence_log_message)
2620 if $diagnostics_object && $iterm > 2;
2621 $rstatus->{'converged'} = 1;
2624 } ## end if ($do_convergence_test)
2630 if ( defined($iteration_of_formatter_convergence) ) {
2632 # This message cannot appear unless the formatter
2633 # convergence test above is temporarily skipped for
2635 if ( $iteration_of_formatter_convergence < $iter - 1 ) {
2637 "STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n";
2640 elsif ( !$stopping_on_error ) {
2642 "STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n";
2646 # we are stopping the iterations early;
2647 # copy the output stream to its final destination
2648 $sink_object = $sink_object_final;
2649 while ( my $line = $source_object->get_line() ) {
2650 $sink_object->write_line($line);
2652 $source_object->close_input_file();
2655 } ## end if ( $iter < $max_iterations)
2656 } ## end loop over iterations for one source file
2658 $sink_object->close_output_file() if $sink_object;
2659 $debugger_object->close_debug_file() if $debugger_object;
2660 $fh_tee->close() if $fh_tee;
2662 # leave logger object open for additional messages
2663 $logger_object = $logger_object_final;
2664 $logger_object->write_logfile_entry($convergence_log_message)
2665 if $convergence_log_message;
2669 } ## end sub process_iteration_layer
2671 sub process_single_case {
2673 # run the formatter on a single defined case
2674 my ( $tokenizer, $formatter ) = @_;
2676 # Total formatting is done with these layers of subroutines:
2677 # perltidy - main routine; checks run parameters
2678 # process_all_files - main loop to process all files;
2679 # process_filter_layer - do any pre and post processing;
2680 # process_iteration_layer - do any iterations on formatting
2681 # *process_single_case - solve one formatting problem; *THIS LAYER
2683 while ( my $line = $tokenizer->get_line() ) {
2684 $formatter->write_line($line);
2686 my $severe_error = $tokenizer->report_tokenization_errors();
2688 # user-defined formatters are possible, and may not have a
2689 # sub 'finish_formatting', so we have to check
2690 $formatter->finish_formatting($severe_error)
2691 if $formatter->can('finish_formatting');
2694 } ## end sub process_single_case
2696 sub copy_buffer_to_destination {
2698 my ( $self, $destination_buffer, $destination_stream,
2699 $encode_destination_buffer )
2702 # Copy $destination_buffer to the final $destination_stream,
2703 # encoding if the flag $encode_destination_buffer is true.
2706 # $destination_buffer -> [ encode? ] -> $destination_stream
2708 $rstatus->{'output_encoded_as'} = EMPTY_STRING;
2710 if ($encode_destination_buffer) {
2715 Encode::encode( "UTF-8", $destination_buffer,
2716 Encode::FB_CROAK | Encode::LEAVE_SRC );
2723 "Error attempting to encode output string ref; encoding not done\n"
2727 $destination_buffer = $encoded_buffer;
2728 $rstatus->{'output_encoded_as'} = 'UTF-8';
2732 # Send data for SCALAR, ARRAY & OBJ refs to its final destination
2733 if ( ref($destination_stream) eq 'SCALAR' ) {
2734 ${$destination_stream} = $destination_buffer;
2736 elsif ($destination_buffer) {
2737 my @lines = split /^/, $destination_buffer;
2738 if ( ref($destination_stream) eq 'ARRAY' ) {
2739 @{$destination_stream} = @lines;
2742 # destination stream must be an object with print method
2744 foreach my $line (@lines) {
2745 $destination_stream->print($line);
2747 my $ref_destination_stream = ref($destination_stream);
2748 if ( $ref_destination_stream->can('close') ) {
2749 $destination_stream->close();
2755 # Empty destination buffer not going to a string ... could
2756 # happen for example if user deleted all pod or comments
2759 } ## end sub copy_buffer_to_destination
2761 } ## end of closure for sub perltidy
2765 # Given two strings, return
2766 # $diff_marker = a string with carat (^) symbols indicating differences
2767 # $pos1 = character position of first difference; pos1=-1 if no difference
2769 # Form exclusive or of the strings, which has null characters where strings
2770 # have same common characters so non-null characters indicate character
2772 my ( $s1, $s2 ) = @_;
2773 my $diff_marker = EMPTY_STRING;
2776 if ( defined($s1) && defined($s2) ) {
2778 my $mask = $s1 ^ $s2;
2780 while ( $mask =~ /[^\0]/g ) {
2782 my $pos_last = $pos;
2783 $pos = $LAST_MATCH_START[0];
2784 if ( $count == 1 ) { $pos1 = $pos; }
2785 $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
2787 # we could continue to mark all differences, but there is no point
2791 return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
2792 } ## end sub line_diff
2794 sub compare_string_buffers {
2796 # Compare input and output string buffers and return a brief text
2797 # description of the first difference.
2798 my ( $bufi, $bufo, $is_encoded_data ) = @_;
2800 my $leni = length($bufi);
2801 my $leno = defined($bufo) ? length($bufo) : 0;
2803 "Input file length is $leni chars\nOutput file length is $leno chars\n";
2804 return $msg unless $leni && $leno;
2806 my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
2807 my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
2808 return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
2809 my ( $linei, $lineo );
2810 my ( $counti, $counto ) = ( 0, 0 );
2811 my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
2812 my $truncate = sub {
2813 my ( $str, $lenmax ) = @_;
2814 if ( length($str) > $lenmax ) {
2815 $str = substr( $str, 0, $lenmax ) . "...";
2821 $last_nonblank_line = $linei;
2822 $last_nonblank_count = $counti;
2824 $linei = $fhi->getline();
2825 $lineo = $fho->getline();
2827 # compare chomp'ed lines
2828 if ( defined($linei) ) { $counti++; chomp $linei }
2829 if ( defined($lineo) ) { $counto++; chomp $lineo }
2831 # see if one or both ended before a difference
2832 last unless ( defined($linei) && defined($lineo) );
2834 next if ( $linei eq $lineo );
2837 my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
2838 my $reason = "Files first differ at character $pos1 of line $counti";
2840 my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
2841 if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
2842 if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
2843 if ( $leading_ws_i ne $leading_ws_o ) {
2844 $reason .= "; leading whitespace differs";
2845 if ( $leading_ws_i =~ /\t/ ) {
2846 $reason .= "; input has tab char";
2850 my ( $trailing_ws_i, $trailing_ws_o ) =
2851 ( EMPTY_STRING, EMPTY_STRING );
2852 if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
2853 if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
2854 if ( $trailing_ws_i ne $trailing_ws_o ) {
2855 $reason .= "; trailing whitespace differs";
2858 $msg .= $reason . "\n";
2860 # limit string display length
2862 my $drop = $pos1 - 40;
2863 $linei = "..." . substr( $linei, $drop );
2864 $lineo = "..." . substr( $lineo, $drop );
2865 $line_diff = SPACE x 3 . substr( $line_diff, $drop );
2867 $linei = $truncate->( $linei, 72 );
2868 $lineo = $truncate->( $lineo, 72 );
2869 $last_nonblank_line = $truncate->( $last_nonblank_line, 72 );
2871 if ($last_nonblank_line) {
2872 my $countm = $counti - 1;
2874 $last_nonblank_count:$last_nonblank_line
2877 $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
2886 # no line differences found, but one file may have fewer lines
2887 if ( $counti > $counto ) {
2889 Files initially match file but output file has fewer lines
2892 elsif ( $counti < $counto ) {
2894 Files initially match file but input file has fewer lines
2899 Text in lines of file match but checksums differ. Perhaps line endings differ.
2903 } ## end sub compare_string_buffers
2905 sub fileglob_to_re {
2907 # modified (corrected) from version in find2perl
2909 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
2910 $x =~ s#\*#.*#g; # '*' -> '.*'
2911 $x =~ s#\?#.#g; # '?' -> '.'
2912 return "^$x\\z"; # match whole word
2915 sub make_logfile_header {
2916 my ( $rOpts, $config_file, $rraw_options, $Windows_type, $readable_options )
2919 # Note: the punctuation variable '$]' is not in older versions of
2920 # English.pm so leave it as is to avoid failing installation tests.
2922 "perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n";
2923 if ($Windows_type) {
2924 $msg .= "Windows type is $Windows_type\n";
2926 my $options_string = join( SPACE, @{$rraw_options} );
2929 $msg .= "Found Configuration File >>> $config_file \n";
2931 $msg .= "Configuration and command line parameters for this run:\n";
2932 $msg .= "$options_string\n";
2934 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
2935 $rOpts->{'logfile'} = 1; # force logfile to be saved
2936 $msg .= "Final parameter set for this run\n";
2937 $msg .= "------------------------------------\n";
2939 $msg .= $readable_options;
2941 $msg .= "------------------------------------\n";
2943 $msg .= "To find error messages search for 'WARNING' with your editor\n";
2945 } ## end sub make_logfile_header
2947 sub write_logfile_header {
2949 $rOpts, $logger_object, $config_file,
2950 $rraw_options, $Windows_type, $readable_options
2953 my $msg = make_logfile_header( $rOpts, $config_file,
2954 $rraw_options, $Windows_type, $readable_options );
2956 $logger_object->write_logfile_entry($msg);
2958 } ## end sub write_logfile_header
2960 sub generate_options {
2962 ######################################################################
2963 # Generate and return references to:
2964 # @option_string - the list of options to be passed to Getopt::Long
2965 # @defaults - the list of default options
2966 # %expansion - a hash showing how all abbreviations are expanded
2967 # %category - a hash giving the general category of each option
2968 # %option_range - a hash giving the valid ranges of certain options
2970 # Note: a few options are not documented in the man page and usage
2971 # message. This is because these are experimental or debug options and
2972 # may or may not be retained in future versions.
2974 # Here are the undocumented flags as far as I know. Any of them
2975 # may disappear at any time. They are mainly for fine-tuning
2978 # fll --> fuzzy-line-length # a trivial parameter which gets
2979 # turned off for the extrude option
2980 # which is mainly for debugging
2981 # scl --> short-concatenation-item-length # helps break at '.'
2982 # recombine # for debugging line breaks
2983 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
2984 ######################################################################
2986 # here is a summary of the Getopt codes:
2987 # <none> does not take an argument
2988 # =s takes a mandatory string
2989 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
2990 # =i takes a mandatory integer
2991 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
2992 # ! does not take an argument and may be negated
2993 # i.e., -foo and -nofoo are allowed
2994 # a double dash signals the end of the options list
2996 #-----------------------------------------------
2997 # Define the option string passed to GetOptions.
2998 #-----------------------------------------------
3000 my @option_string = ();
3002 my %option_category = ();
3003 my %option_range = ();
3004 my $rexpansion = \%expansion;
3006 # names of categories in manual
3007 # leading integers will allow sorting
3008 my @category_name = (
3010 '1. Basic formatting options',
3011 '2. Code indentation control',
3012 '3. Whitespace control',
3013 '4. Comment controls',
3014 '5. Linebreak controls',
3015 '6. Controlling list formatting',
3016 '7. Retaining or ignoring existing line breaks',
3017 '8. Blank line control',
3018 '9. Other controls',
3020 '11. pod2html options',
3021 '12. Controlling HTML properties',
3025 # These options are parsed directly by perltidy:
3028 # However, they are included in the option set so that they will
3029 # be seen in the options dump.
3031 # These long option names have no abbreviations or are treated specially
3032 @option_string = qw(
3041 my $category = 13; # Debugging
3042 foreach (@option_string) {
3043 my $opt = $_; # must avoid changing the actual flag
3045 $option_category{$opt} = $category_name[$category];
3048 $category = 11; # HTML
3049 $option_category{html} = $category_name[$category];
3051 # routine to install and check options
3052 my $add_option = sub {
3053 my ( $long_name, $short_name, $flag ) = @_;
3054 push @option_string, $long_name . $flag;
3055 $option_category{$long_name} = $category_name[$category];
3057 if ( $expansion{$short_name} ) {
3058 my $existing_name = $expansion{$short_name}[0];
3060 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
3063 $expansion{$short_name} = [$long_name];
3064 if ( $flag eq '!' ) {
3065 my $nshort_name = 'n' . $short_name;
3066 my $nolong_name = 'no' . $long_name;
3067 if ( $expansion{$nshort_name} ) {
3068 my $existing_name = $expansion{$nshort_name}[0];
3070 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
3073 $expansion{$nshort_name} = [$nolong_name];
3079 # Install long option names which have a simple abbreviation.
3080 # Options with code '!' get standard negation ('no' for long names,
3081 # 'n' for abbreviations). Categories follow the manual.
3083 ###########################
3084 $category = 0; # I/O_Control
3085 ###########################
3086 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
3087 $add_option->( 'backup-file-extension', 'bext', '=s' );
3088 $add_option->( 'backup-method', 'bm', '=s' );
3089 $add_option->( 'character-encoding', 'enc', '=s' );
3090 $add_option->( 'force-read-binary', 'f', '!' );
3091 $add_option->( 'format', 'fmt', '=s' );
3092 $add_option->( 'iterations', 'it', '=i' );
3093 $add_option->( 'logfile', 'log', '!' );
3094 $add_option->( 'logfile-gap', 'g', ':i' );
3095 $add_option->( 'outfile', 'o', '=s' );
3096 $add_option->( 'output-file-extension', 'oext', '=s' );
3097 $add_option->( 'output-path', 'opath', '=s' );
3098 $add_option->( 'profile', 'pro', '=s' );
3099 $add_option->( 'quiet', 'q', '!' );
3100 $add_option->( 'standard-error-output', 'se', '!' );
3101 $add_option->( 'standard-output', 'st', '!' );
3102 $add_option->( 'use-unicode-gcstring', 'gcs', '!' );
3103 $add_option->( 'warning-output', 'w', '!' );
3104 $add_option->( 'add-terminal-newline', 'atnl', '!' );
3106 # options which are both toggle switches and values moved here
3107 # to hide from tidyview (which does not show category 0 flags):
3108 # -ole moved here from category 1
3109 # -sil moved here from category 2
3110 $add_option->( 'output-line-ending', 'ole', '=s' );
3111 $add_option->( 'starting-indentation-level', 'sil', '=i' );
3113 ########################################
3114 $category = 1; # Basic formatting options
3115 ########################################
3116 $add_option->( 'check-syntax', 'syn', '!' );
3117 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
3118 $add_option->( 'indent-columns', 'i', '=i' );
3119 $add_option->( 'maximum-line-length', 'l', '=i' );
3120 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
3121 $add_option->( 'whitespace-cycle', 'wc', '=i' );
3122 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
3123 $add_option->( 'preserve-line-endings', 'ple', '!' );
3124 $add_option->( 'tabs', 't', '!' );
3125 $add_option->( 'default-tabsize', 'dt', '=i' );
3126 $add_option->( 'extended-syntax', 'xs', '!' );
3127 $add_option->( 'assert-tidy', 'ast', '!' );
3128 $add_option->( 'assert-untidy', 'asu', '!' );
3129 $add_option->( 'encode-output-strings', 'eos', '!' );
3130 $add_option->( 'sub-alias-list', 'sal', '=s' );
3131 $add_option->( 'grep-alias-list', 'gal', '=s' );
3132 $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' );
3134 ########################################
3135 $category = 2; # Code indentation control
3136 ########################################
3137 $add_option->( 'continuation-indentation', 'ci', '=i' );
3138 $add_option->( 'extended-continuation-indentation', 'xci', '!' );
3139 $add_option->( 'line-up-parentheses', 'lp', '!' );
3140 $add_option->( 'extended-line-up-parentheses', 'xlp', '!' );
3141 $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' );
3142 $add_option->( 'line-up-parentheses-inclusion-list', 'lpil', '=s' );
3143 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
3144 $add_option->( 'outdent-keywords', 'okw', '!' );
3145 $add_option->( 'outdent-labels', 'ola', '!' );
3146 $add_option->( 'outdent-long-quotes', 'olq', '!' );
3147 $add_option->( 'indent-closing-brace', 'icb', '!' );
3148 $add_option->( 'closing-token-indentation', 'cti', '=i' );
3149 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
3150 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
3151 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
3152 $add_option->( 'brace-left-and-indent', 'bli', '!' );
3153 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
3154 $add_option->( 'brace-left-and-indent-exclusion-list', 'blixl', '=s' );
3156 ########################################
3157 $category = 3; # Whitespace control
3158 ########################################
3159 $add_option->( 'add-trailing-commas', 'atc', '!' );
3160 $add_option->( 'add-semicolons', 'asc', '!' );
3161 $add_option->( 'add-whitespace', 'aws', '!' );
3162 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
3163 $add_option->( 'brace-tightness', 'bt', '=i' );
3164 $add_option->( 'delete-old-whitespace', 'dws', '!' );
3165 $add_option->( 'delete-repeated-commas', 'drc', '!' );
3166 $add_option->( 'delete-trailing-commas', 'dtc', '!' );
3167 $add_option->( 'delete-weld-interfering-commas', 'dwic', '!' );
3168 $add_option->( 'delete-semicolons', 'dsm', '!' );
3169 $add_option->( 'function-paren-vertical-alignment', 'fpva', '!' );
3170 $add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' );
3171 $add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' );
3172 $add_option->( 'logical-padding', 'lop', '!' );
3173 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
3174 $add_option->( 'nowant-left-space', 'nwls', '=s' );
3175 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
3176 $add_option->( 'paren-tightness', 'pt', '=i' );
3177 $add_option->( 'space-after-keyword', 'sak', '=s' );
3178 $add_option->( 'space-for-semicolon', 'sfs', '!' );
3179 $add_option->( 'space-function-paren', 'sfp', '!' );
3180 $add_option->( 'space-keyword-paren', 'skp', '!' );
3181 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
3182 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
3183 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
3184 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
3185 $add_option->( 'tight-secret-operators', 'tso', '!' );
3186 $add_option->( 'trim-qw', 'tqw', '!' );
3187 $add_option->( 'trim-pod', 'trp', '!' );
3188 $add_option->( 'want-left-space', 'wls', '=s' );
3189 $add_option->( 'want-right-space', 'wrs', '=s' );
3190 $add_option->( 'want-trailing-commas', 'wtc', '=s' );
3191 $add_option->( 'space-prototype-paren', 'spp', '=i' );
3192 $add_option->( 'valign-code', 'vc', '!' );
3193 $add_option->( 'valign-block-comments', 'vbc', '!' );
3194 $add_option->( 'valign-side-comments', 'vsc', '!' );
3195 $add_option->( 'valign-exclusion-list', 'vxl', '=s' );
3196 $add_option->( 'valign-inclusion-list', 'vil', '=s' );
3198 ########################################
3199 $category = 4; # Comment controls
3200 ########################################
3201 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
3202 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
3203 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
3204 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
3205 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
3206 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
3207 $add_option->( 'closing-side-comments', 'csc', '!' );
3208 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
3209 $add_option->( 'code-skipping', 'cs', '!' );
3210 $add_option->( 'code-skipping-begin', 'csb', '=s' );
3211 $add_option->( 'code-skipping-end', 'cse', '=s' );
3212 $add_option->( 'format-skipping', 'fs', '!' );
3213 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
3214 $add_option->( 'format-skipping-end', 'fse', '=s' );
3215 $add_option->( 'hanging-side-comments', 'hsc', '!' );
3216 $add_option->( 'indent-block-comments', 'ibc', '!' );
3217 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
3218 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
3219 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
3220 $add_option->( 'non-indenting-braces', 'nib', '!' );
3221 $add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' );
3222 $add_option->( 'outdent-long-comments', 'olc', '!' );
3223 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
3224 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
3225 $add_option->( 'static-block-comments', 'sbc', '!' );
3226 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
3227 $add_option->( 'static-side-comments', 'ssc', '!' );
3228 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
3230 ########################################
3231 $category = 5; # Linebreak controls
3232 ########################################
3233 $add_option->( 'add-newlines', 'anl', '!' );
3234 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
3235 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
3236 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
3237 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
3238 $add_option->( 'cuddled-else', 'ce', '!' );
3239 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
3240 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
3241 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
3242 $add_option->( 'delete-old-newlines', 'dnl', '!' );
3243 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
3244 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
3245 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
3246 $add_option->( 'opening-paren-right', 'opr', '!' );
3247 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
3248 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
3249 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
3250 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
3251 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
3252 $add_option->( 'weld-nested-containers', 'wn', '!' );
3253 $add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' );
3254 $add_option->( 'weld-fat-comma', 'wfc', '!' );
3255 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
3256 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
3257 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
3258 $add_option->( 'stack-closing-paren', 'scp', '!' );
3259 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
3260 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
3261 $add_option->( 'stack-opening-paren', 'sop', '!' );
3262 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
3263 $add_option->( 'vertical-tightness', 'vt', '=i' );
3264 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
3265 $add_option->( 'want-break-after', 'wba', '=s' );
3266 $add_option->( 'want-break-before', 'wbb', '=s' );
3267 $add_option->( 'break-after-all-operators', 'baao', '!' );
3268 $add_option->( 'break-before-all-operators', 'bbao', '!' );
3269 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
3270 $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
3271 $add_option->( 'one-line-block-nesting', 'olbn', '=i' );
3272 $add_option->( 'break-before-hash-brace', 'bbhb', '=i' );
3273 $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' );
3274 $add_option->( 'break-before-square-bracket', 'bbsb', '=i' );
3275 $add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' );
3276 $add_option->( 'break-before-paren', 'bbp', '=i' );
3277 $add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' );
3278 $add_option->( 'brace-left-list', 'bll', '=s' );
3279 $add_option->( 'brace-left-exclusion-list', 'blxl', '=s' );
3280 $add_option->( 'break-after-labels', 'bal', '=i' );
3282 # This was an experiment mentioned in git #78, originally named -bopl. I
3283 # expanded it to also open logical blocks, based on git discussion #100,
3284 # and renamed it -bocp. It works, but will remain commented out due to
3285 # apparent lack of interest.
3286 # $add_option->( 'break-open-compact-parens', 'bocp', '=s' );
3288 ########################################
3289 $category = 6; # Controlling list formatting
3290 ########################################
3291 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
3292 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
3293 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
3295 ########################################
3296 $category = 7; # Retaining or ignoring existing line breaks
3297 ########################################
3298 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
3299 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
3300 $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
3301 $add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' );
3302 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
3303 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
3304 $add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' );
3305 $add_option->( 'keep-old-breakpoints-after', 'kba', '=s' );
3306 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
3308 ########################################
3309 $category = 8; # Blank line control
3310 ########################################
3311 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
3312 $add_option->( 'blanks-before-comments', 'bbc', '!' );
3313 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
3314 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
3315 $add_option->( 'long-block-line-count', 'lbl', '=i' );
3316 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
3317 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
3319 $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
3320 $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
3321 $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
3322 $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
3323 $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
3324 $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
3325 $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
3327 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
3328 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
3329 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
3330 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
3332 ########################################
3333 $category = 9; # Other controls
3334 ########################################
3335 $add_option->( 'delete-block-comments', 'dbc', '!' );
3336 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
3337 $add_option->( 'delete-pod', 'dp', '!' );
3338 $add_option->( 'delete-side-comments', 'dsc', '!' );
3339 $add_option->( 'tee-block-comments', 'tbc', '!' );
3340 $add_option->( 'tee-pod', 'tp', '!' );
3341 $add_option->( 'tee-side-comments', 'tsc', '!' );
3342 $add_option->( 'look-for-autoloader', 'lal', '!' );
3343 $add_option->( 'look-for-hash-bang', 'x', '!' );
3344 $add_option->( 'look-for-selfloader', 'lsl', '!' );
3345 $add_option->( 'pass-version-line', 'pvl', '!' );
3347 ########################################
3348 $category = 13; # Debugging
3349 ########################################
3350 $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
3351 $add_option->( 'DEBUG', 'D', '!' );
3352 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
3353 $add_option->( 'dump-defaults', 'ddf', '!' );
3354 $add_option->( 'dump-long-names', 'dln', '!' );
3355 $add_option->( 'dump-options', 'dop', '!' );
3356 $add_option->( 'dump-profile', 'dpro', '!' );
3357 $add_option->( 'dump-short-names', 'dsn', '!' );
3358 $add_option->( 'dump-token-types', 'dtt', '!' );
3359 $add_option->( 'dump-want-left-space', 'dwls', '!' );
3360 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
3361 $add_option->( 'fuzzy-line-length', 'fll', '!' );
3362 $add_option->( 'help', 'h', EMPTY_STRING );
3363 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
3364 $add_option->( 'show-options', 'opt', '!' );
3365 $add_option->( 'timestamp', 'ts', '!' );
3366 $add_option->( 'version', 'v', EMPTY_STRING );
3367 $add_option->( 'memoize', 'mem', '!' );
3368 $add_option->( 'file-size-order', 'fso', '!' );
3369 $add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
3370 $add_option->( 'maximum-level-errors', 'maxle', '=i' );
3371 $add_option->( 'maximum-unexpected-errors', 'maxue', '=i' );
3373 #---------------------------------------------------------------------
3375 # The Perl::Tidy::HtmlWriter will add its own options to the string
3376 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
3378 ########################################
3379 # Set categories 10, 11, 12
3380 ########################################
3381 # Based on their known order
3382 $category = 12; # HTML properties
3383 foreach my $opt (@option_string) {
3384 my $long_name = $opt;
3385 $long_name =~ s/(!|=.*|:.*)$//;
3386 unless ( defined( $option_category{$long_name} ) ) {
3387 if ( $long_name =~ /^html-linked/ ) {
3388 $category = 10; # HTML options
3390 elsif ( $long_name =~ /^pod2html/ ) {
3391 $category = 11; # Pod2html
3393 $option_category{$long_name} = $category_name[$category];
3397 #---------------------------------------
3398 # Assign valid ranges to certain options
3399 #---------------------------------------
3400 # In the future, these may be used to make preliminary checks
3401 # hash keys are long names
3402 # If key or value is undefined:
3403 # strings may have any value
3404 # integer ranges are >=0
3405 # If value is defined:
3406 # value is [qw(any valid words)] for strings
3407 # value is [min, max] for integers
3408 # if min is undefined, there is no lower limit
3409 # if max is undefined, there is no upper limit
3410 # Parameters not listed here have defaults
3412 'format' => [ 'tidy', 'html', 'user' ],
3413 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
3414 'space-backslash-quote' => [ 0, 2 ],
3415 'block-brace-tightness' => [ 0, 2 ],
3416 'keyword-paren-inner-tightness' => [ 0, 2 ],
3417 'brace-tightness' => [ 0, 2 ],
3418 'paren-tightness' => [ 0, 2 ],
3419 'square-bracket-tightness' => [ 0, 2 ],
3421 'block-brace-vertical-tightness' => [ 0, 2 ],
3422 'brace-vertical-tightness' => [ 0, 2 ],
3423 'brace-vertical-tightness-closing' => [ 0, 2 ],
3424 'paren-vertical-tightness' => [ 0, 2 ],
3425 'paren-vertical-tightness-closing' => [ 0, 2 ],
3426 'square-bracket-vertical-tightness' => [ 0, 2 ],
3427 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
3428 'vertical-tightness' => [ 0, 2 ],
3429 'vertical-tightness-closing' => [ 0, 2 ],
3431 'closing-brace-indentation' => [ 0, 3 ],
3432 'closing-paren-indentation' => [ 0, 3 ],
3433 'closing-square-bracket-indentation' => [ 0, 3 ],
3434 'closing-token-indentation' => [ 0, 3 ],
3436 'closing-side-comment-else-flag' => [ 0, 2 ],
3437 'comma-arrow-breakpoints' => [ 0, 5 ],
3439 'keyword-group-blanks-before' => [ 0, 2 ],
3440 'keyword-group-blanks-after' => [ 0, 2 ],
3442 'space-prototype-paren' => [ 0, 2 ],
3443 'break-after-labels' => [ 0, 2 ],
3446 # Note: we could actually allow negative ci if someone really wants it:
3447 # $option_range{'continuation-indentation'} = [ undef, undef ];
3449 #------------------------------------------------------------------
3450 # DEFAULTS: Assign default values to the above options here, except
3451 # for 'outfile' and 'help'.
3452 # These settings should approximate the perlstyle(1) suggestions.
3453 #------------------------------------------------------------------
3456 add-terminal-newline
3459 blanks-before-blocks
3460 blanks-before-comments
3461 blank-lines-before-subs=1
3462 blank-lines-before-packages=1
3464 keyword-group-blanks-size=5
3465 keyword-group-blanks-repeat-count=0
3466 keyword-group-blanks-before=1
3467 keyword-group-blanks-after=1
3468 nokeyword-group-blanks-inside
3469 nokeyword-group-blanks-delete
3471 block-brace-tightness=0
3472 block-brace-vertical-tightness=0
3474 brace-vertical-tightness-closing=0
3475 brace-vertical-tightness=0
3476 break-after-labels=0
3477 break-at-old-logical-breakpoints
3478 break-at-old-ternary-breakpoints
3479 break-at-old-attribute-breakpoints
3480 break-at-old-keyword-breakpoints
3481 break-before-hash-brace=0
3482 break-before-hash-brace-and-indent=0
3483 break-before-square-bracket=0
3484 break-before-square-bracket-and-indent=0
3485 break-before-paren=0
3486 break-before-paren-and-indent=0
3487 comma-arrow-breakpoints=5
3489 character-encoding=guess
3490 closing-side-comment-interval=6
3491 closing-side-comment-maximum-text=20
3492 closing-side-comment-else-flag=0
3493 closing-side-comments-balanced
3494 closing-paren-indentation=0
3495 closing-brace-indentation=0
3496 closing-square-bracket-indentation=0
3497 continuation-indentation=2
3498 noextended-continuation-indentation
3499 cuddled-break-option=1
3503 encode-output-strings
3504 function-paren-vertical-alignment
3506 hanging-side-comments
3507 indent-block-comments
3510 keep-old-blank-lines=1
3511 keyword-paren-inner-tightness=1
3513 long-block-line-count=8
3516 maximum-consecutive-blank-lines=1
3517 maximum-fields-per-table=0
3518 maximum-line-length=80
3519 maximum-file-size-mb=10
3520 maximum-level-errors=1
3521 maximum-unexpected-errors=0
3523 minimum-space-to-comment=4
3524 nobrace-left-and-indent
3526 nodelete-old-whitespace
3529 non-indenting-braces
3532 nostatic-side-comments
3535 one-line-block-semicolons=1
3536 one-line-block-nesting=0
3539 outdent-long-comments
3541 paren-vertical-tightness-closing=0
3542 paren-vertical-tightness=0
3544 noweld-nested-containers
3546 nouse-unicode-gcstring
3548 valign-block-comments
3549 valign-side-comments
3550 short-concatenation-item-length=8
3552 space-backslash-quote=1
3553 space-prototype-paren=1
3554 square-bracket-tightness=1
3555 square-bracket-vertical-tightness-closing=0
3556 square-bracket-vertical-tightness=0
3557 static-block-comments
3562 backup-file-extension=bak
3568 html-table-of-contents
3572 push @defaults, "perl-syntax-check-flags=-c -T";
3574 #-----------------------------------------------------------------------
3575 # Define abbreviations which will be expanded into the above primitives.
3576 # These may be defined recursively.
3577 #-----------------------------------------------------------------------
3580 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
3581 'fnl' => [qw(freeze-newlines)],
3582 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
3583 'fws' => [qw(freeze-whitespace)],
3584 'freeze-blank-lines' =>
3585 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
3586 'fbl' => [qw(freeze-blank-lines)],
3587 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
3588 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
3589 'nooutdent-long-lines' =>
3590 [qw(nooutdent-long-quotes nooutdent-long-comments)],
3591 'oll' => [qw(outdent-long-lines)],
3592 'noll' => [qw(nooutdent-long-lines)],
3593 'io' => [qw(indent-only)],
3594 'delete-all-comments' =>
3595 [qw(delete-block-comments delete-side-comments delete-pod)],
3596 'nodelete-all-comments' =>
3597 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
3598 'dac' => [qw(delete-all-comments)],
3599 'ndac' => [qw(nodelete-all-comments)],
3600 'gnu' => [qw(gnu-style)],
3601 'pbp' => [qw(perl-best-practices)],
3602 'tee-all-comments' =>
3603 [qw(tee-block-comments tee-side-comments tee-pod)],
3604 'notee-all-comments' =>
3605 [qw(notee-block-comments notee-side-comments notee-pod)],
3606 'tac' => [qw(tee-all-comments)],
3607 'ntac' => [qw(notee-all-comments)],
3608 'html' => [qw(format=html)],
3609 'nhtml' => [qw(format=tidy)],
3610 'tidy' => [qw(format=tidy)],
3612 'brace-left' => [qw(opening-brace-on-new-line)],
3614 # -cb is now a synonym for -ce
3615 'cb' => [qw(cuddled-else)],
3616 'cuddled-blocks' => [qw(cuddled-else)],
3618 'utf8' => [qw(character-encoding=utf8)],
3619 'UTF8' => [qw(character-encoding=utf8)],
3620 'guess' => [qw(character-encoding=guess)],
3622 'swallow-optional-blank-lines' => [qw(kbl=0)],
3623 'noswallow-optional-blank-lines' => [qw(kbl=1)],
3624 'sob' => [qw(kbl=0)],
3625 'nsob' => [qw(kbl=1)],
3627 'break-after-comma-arrows' => [qw(cab=0)],
3628 'nobreak-after-comma-arrows' => [qw(cab=1)],
3629 'baa' => [qw(cab=0)],
3630 'nbaa' => [qw(cab=1)],
3632 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
3633 'bbs' => [qw(blbs=1 blbp=1)],
3634 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
3635 'nbbs' => [qw(blbs=0 blbp=0)],
3637 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
3638 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
3639 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
3640 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
3642 'break-at-old-trinary-breakpoints' => [qw(bot)],
3644 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
3645 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
3646 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
3647 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
3648 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
3650 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
3651 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
3652 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
3653 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
3654 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
3656 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3657 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3658 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3660 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3661 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3662 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3664 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3665 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3666 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3668 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3669 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3670 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3672 'otr' => [qw(opr ohbr osbr)],
3673 'opening-token-right' => [qw(opr ohbr osbr)],
3674 'notr' => [qw(nopr nohbr nosbr)],
3675 'noopening-token-right' => [qw(nopr nohbr nosbr)],
3677 'sot' => [qw(sop sohb sosb)],
3678 'nsot' => [qw(nsop nsohb nsosb)],
3679 'stack-opening-tokens' => [qw(sop sohb sosb)],
3680 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
3682 'sct' => [qw(scp schb scsb)],
3683 'stack-closing-tokens' => [qw(scp schb scsb)],
3684 'nsct' => [qw(nscp nschb nscsb)],
3685 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
3687 'sac' => [qw(sot sct)],
3688 'nsac' => [qw(nsot nsct)],
3689 'stack-all-containers' => [qw(sot sct)],
3690 'nostack-all-containers' => [qw(nsot nsct)],
3692 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3693 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3694 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3695 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3696 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3697 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3699 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
3700 'sobb' => [qw(bbvt=2 bbvtl=*)],
3701 'nostack-opening-block-brace' => [qw(bbvt=0)],
3702 'nsobb' => [qw(bbvt=0)],
3704 'converge' => [qw(it=4)],
3705 'noconverge' => [qw(it=1)],
3706 'conv' => [qw(it=4)],
3707 'nconv' => [qw(it=1)],
3709 'valign' => [qw(vc vsc vbc)],
3710 'novalign' => [qw(nvc nvsc nvbc)],
3712 # NOTE: This is a possible future shortcut. But it will remain
3713 # deactivated until the -lpxl flag is no longer experimental.
3714 # 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ],
3715 # 'lfp' => [qw(line-up-function-parentheses)],
3717 # 'mangle' originally deleted pod and comments, but to keep it
3718 # reversible, it no longer does. But if you really want to
3719 # delete them, just use:
3722 # An interesting use for 'mangle' is to do this:
3723 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
3724 # which will form as many one-line blocks as possible
3728 keep-old-blank-lines=0
3730 delete-old-whitespace
3733 maximum-consecutive-blank-lines=0
3734 maximum-line-length=100000
3738 noblanks-before-blocks
3739 blank-lines-before-subs=0
3740 blank-lines-before-packages=0
3745 # 'extrude' originally deleted pod and comments, but to keep it
3746 # reversible, it no longer does. But if you really want to
3747 # delete them, just use
3750 # An interesting use for 'extrude' is to do this:
3751 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
3752 # which will break up all one-line blocks.
3757 delete-old-whitespace
3760 maximum-consecutive-blank-lines=0
3761 maximum-line-length=1
3764 noblanks-before-blocks
3765 blank-lines-before-subs=0
3766 blank-lines-before-packages=0
3773 # this style tries to follow the GNU Coding Standards (which do
3774 # not really apply to perl but which are followed by some perl
3778 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
3782 # Style suggested in Damian Conway's Perl Best Practices
3783 'perl-best-practices' => [
3784 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
3785 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
3788 # Additional styles can be added here
3791 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
3793 # Uncomment next line to dump all expansions for debugging:
3794 # dump_short_names(\%expansion);
3796 \@option_string, \@defaults, \%expansion,
3797 \%option_category, \%option_range
3800 } ## end sub generate_options
3802 # Memoize process_command_line. Given same @ARGV passed in, return same
3803 # values and same @ARGV back.
3804 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
3805 # up masontidy (https://metacpan.org/module/masontidy)
3807 my %process_command_line_cache;
3809 sub process_command_line {
3813 $perltidyrc_stream, $is_Windows, $Windows_type,
3814 $rpending_complaint, $dump_options_type
3817 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
3819 my $cache_key = join( chr(28), @ARGV );
3820 if ( my $result = $process_command_line_cache{$cache_key} ) {
3821 my ( $argv, @retvals ) = @{$result};
3826 my @retvals = _process_command_line(@q);
3827 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
3828 if $retvals[0]->{'memoize'};
3833 return _process_command_line(@q);
3835 } ## end sub process_command_line
3837 # (note the underscore here)
3838 sub _process_command_line {
3841 $perltidyrc_stream, $is_Windows, $Windows_type,
3842 $rpending_complaint, $dump_options_type
3847 # Save any current Getopt::Long configuration
3848 # and set to Getopt::Long defaults. Use eval to avoid
3849 # breaking old versions of Perl without these routines.
3850 # Previous configuration is reset at the exit of this routine.
3852 if ( eval { $glc = Getopt::Long::Configure(); 1 } ) {
3853 my $ok = eval { Getopt::Long::ConfigDefaults(); 1 };
3854 if ( !$ok && DEVEL_MODE ) {
3855 Fault("Failed call to Getopt::Long::ConfigDefaults: $EVAL_ERROR\n");
3858 else { $glc = undef }
3861 $roption_string, $rdefaults, $rexpansion,
3862 $roption_category, $roption_range
3863 ) = generate_options();
3865 #--------------------------------------------------------------
3866 # set the defaults by passing the above list through GetOptions
3867 #--------------------------------------------------------------
3872 # do not load the defaults if we are just dumping perltidyrc
3873 unless ( $dump_options_type eq 'perltidyrc' ) {
3874 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
3876 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
3878 "Programming Bug reported by 'GetOptions': error in setting default options"
3884 my @raw_options = ();
3885 my $config_file = EMPTY_STRING;
3886 my $saw_ignore_profile = 0;
3887 my $saw_dump_profile = 0;
3889 #--------------------------------------------------------------
3890 # Take a first look at the command-line parameters. Do as many
3891 # immediate dumps as possible, which can avoid confusion if the
3892 # perltidyrc file has an error.
3893 #--------------------------------------------------------------
3894 foreach my $i (@ARGV) {
3897 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
3898 $saw_ignore_profile = 1;
3901 # note: this must come before -pro and -profile, below:
3902 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
3903 $saw_dump_profile = 1;
3905 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
3908 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
3913 # resolve <dir>/.../<file>, meaning look upwards from directory
3914 if ( defined($config_file) ) {
3915 if ( my ( $start_dir, $search_file ) =
3916 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3918 $start_dir = '.' if !$start_dir;
3919 $start_dir = Cwd::realpath($start_dir);
3920 if ( my $found_file =
3921 find_file_upwards( $start_dir, $search_file ) )
3923 $config_file = $found_file;
3927 unless ( -e $config_file ) {
3928 Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
3929 $config_file = EMPTY_STRING;
3932 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
3933 Die("usage: -pro=filename or --profile=filename, no spaces\n");
3935 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
3939 elsif ( $i =~ /^-(version|v)$/ ) {
3943 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
3944 dump_defaults( @{$rdefaults} );
3947 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
3948 dump_long_names( @{$roption_string} );
3951 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
3952 dump_short_names($rexpansion);
3955 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
3956 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
3961 if ( $saw_dump_profile && $saw_ignore_profile ) {
3962 Warn("No profile to dump because of -npro\n");
3966 #----------------------------------------
3967 # read any .perltidyrc configuration file
3968 #----------------------------------------
3969 unless ($saw_ignore_profile) {
3971 # resolve possible conflict between $perltidyrc_stream passed
3972 # as call parameter to perltidy and -pro=filename on command
3974 if ($perltidyrc_stream) {
3977 Conflict: a perltidyrc configuration file was specified both as this
3978 perltidy call parameter: $perltidyrc_stream
3979 and with this -profile=$config_file.
3980 Using -profile=$config_file.
3984 $config_file = $perltidyrc_stream;
3988 # look for a config file if we don't have one yet
3989 my $rconfig_file_chatter;
3990 ${$rconfig_file_chatter} = EMPTY_STRING;
3992 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
3993 $rpending_complaint )
3994 unless $config_file;
3996 # open any config file
3999 ( $fh_config, $config_file ) =
4000 Perl::Tidy::streamhandle( $config_file, 'r' );
4001 unless ($fh_config) {
4002 ${$rconfig_file_chatter} .=
4003 "# $config_file exists but cannot be opened\n";
4007 if ($saw_dump_profile) {
4008 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
4014 my ( $rconfig_list, $death_message ) =
4015 read_config_file( $fh_config, $config_file, $rexpansion );
4016 Die($death_message) if ($death_message);
4018 # process any .perltidyrc parameters right now so we can
4020 if ( @{$rconfig_list} ) {
4021 local @ARGV = @{$rconfig_list};
4023 expand_command_abbreviations( $rexpansion, \@raw_options,
4026 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
4028 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
4032 # Anything left in this local @ARGV is an error and must be
4033 # invalid bare words from the configuration file. We cannot
4034 # check this earlier because bare words may have been valid
4035 # values for parameters. We had to wait for GetOptions to have
4039 my $str = "\'" . pop(@ARGV) . "\'";
4040 while ( my $param = pop(@ARGV) ) {
4041 if ( length($str) < 70 ) {
4042 $str .= ", '$param'";
4050 There are $count unrecognized values in the configuration file '$config_file':
4052 Use leading dashes for parameters. Use -npro to ignore this file.
4056 # Undo any options which cause premature exit. They are not
4057 # appropriate for a config file, and it could be hard to
4058 # diagnose the cause of the premature exit.
4061 dump-cuddled-block-list
4068 dump-want-left-space
4069 dump-want-right-space
4077 if ( defined( $Opts{$_} ) ) {
4079 Warn("ignoring --$_ in config file: $config_file\n");
4086 #----------------------------------------
4087 # now process the command line parameters
4088 #----------------------------------------
4089 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
4091 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
4092 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
4093 Die("Error on command line; for help try 'perltidy -h'\n");
4096 # reset Getopt::Long configuration back to its previous value
4097 if ( defined($glc) ) {
4098 my $ok = eval { Getopt::Long::Configure($glc); 1 };
4099 if ( !$ok && DEVEL_MODE ) {
4100 Fault("Could not reset Getopt::Long configuration: $EVAL_ERROR\n");
4104 return ( \%Opts, $config_file, \@raw_options, $roption_string,
4105 $rexpansion, $roption_category, $roption_range );
4106 } ## end sub _process_command_line
4108 sub make_grep_alias_string {
4111 # Defaults: list operators in List::Util
4112 # Possible future additions: pairfirst pairgrep pairmap
4113 my $default_string = join SPACE, qw(
4123 # make a hash of any excluded words
4124 my %is_excluded_word;
4125 my $exclude_string = $rOpts->{'grep-alias-exclusion-list'};
4126 if ($exclude_string) {
4127 $exclude_string =~ s/,/ /g; # allow commas
4128 $exclude_string =~ s/^\s+//;
4129 $exclude_string =~ s/\s+$//;
4130 my @q = split /\s+/, $exclude_string;
4131 @is_excluded_word{@q} = (1) x scalar(@q);
4134 # The special option -gaxl='*' removes all defaults
4135 if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING }
4137 # combine the defaults and any input list
4138 my $input_string = $rOpts->{'grep-alias-list'};
4139 if ($input_string) { $input_string .= SPACE . $default_string }
4140 else { $input_string = $default_string }
4142 # Now make the final list of unique grep alias words
4143 $input_string =~ s/,/ /g; # allow commas
4144 $input_string =~ s/^\s+//;
4145 $input_string =~ s/\s+$//;
4146 my @word_list = split /\s+/, $input_string;
4147 my @filtered_word_list;
4150 foreach my $word (@word_list) {
4152 if ( $word !~ /^\w[\w\d]*$/ ) {
4154 "unexpected word in --grep-alias-list: '$word' - ignoring\n"
4157 if ( !$seen{$word} && !$is_excluded_word{$word} ) {
4159 push @filtered_word_list, $word;
4163 my $joined_words = join SPACE, @filtered_word_list;
4164 $rOpts->{'grep-alias-list'} = $joined_words;
4166 } ## end sub make_grep_alias_string
4170 my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
4172 #------------------------------------------------------------
4173 # check and handle any interactions among the basic options..
4174 #------------------------------------------------------------
4176 # Since perltidy only encodes in utf8, problems can occur if we let it
4177 # decode anything else. See discussions for issue git #83.
4178 my $encoding = $rOpts->{'character-encoding'};
4179 if ( $encoding !~ /^\s*(guess|none|utf8|utf-8)\s*$/i ) {
4181 --character-encoding = '$encoding' is not allowed; the options are: 'none', 'guess', 'utf8'
4185 # Since -vt, -vtc, and -cti are abbreviations, but under
4186 # msdos, an unquoted input parameter like vtc=1 will be
4187 # seen as 2 parameters, vtc and 1, so the abbreviations
4188 # won't be seen. Therefore, we will catch them here if
4191 if ( defined $rOpts->{'vertical-tightness'} ) {
4192 my $vt = $rOpts->{'vertical-tightness'};
4193 $rOpts->{'paren-vertical-tightness'} = $vt;
4194 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
4195 $rOpts->{'brace-vertical-tightness'} = $vt;
4198 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
4199 my $vtc = $rOpts->{'vertical-tightness-closing'};
4200 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
4201 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
4202 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
4205 if ( defined $rOpts->{'closing-token-indentation'} ) {
4206 my $cti = $rOpts->{'closing-token-indentation'};
4207 $rOpts->{'closing-square-bracket-indentation'} = $cti;
4208 $rOpts->{'closing-brace-indentation'} = $cti;
4209 $rOpts->{'closing-paren-indentation'} = $cti;
4212 # Syntax checking is no longer supported due to concerns about executing
4213 # code in BEGIN blocks. The flag is still accepted for backwards
4214 # compatibility but is ignored if set.
4215 $rOpts->{'check-syntax'} = 0;
4217 my $check_blank_count = sub {
4218 my ( $key, $abbrev ) = @_;
4219 if ( $rOpts->{$key} ) {
4220 if ( $rOpts->{$key} < 0 ) {
4222 Warn("negative value of $abbrev, setting 0\n");
4224 if ( $rOpts->{$key} > 100 ) {
4225 Warn("unreasonably large value of $abbrev, reducing\n");
4226 $rOpts->{$key} = 100;
4232 # check for reasonable number of blank lines and fix to avoid problems
4233 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
4234 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
4235 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
4236 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
4238 # setting a non-negative logfile gap causes logfile to be saved
4239 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
4240 $rOpts->{'logfile'} = 1;
4243 # set short-cut flag when only indentation is to be done.
4244 # Note that the user may or may not have already set the
4246 if ( !$rOpts->{'add-whitespace'}
4247 && !$rOpts->{'delete-old-whitespace'}
4248 && !$rOpts->{'add-newlines'}
4249 && !$rOpts->{'delete-old-newlines'} )
4251 $rOpts->{'indent-only'} = 1;
4254 # -isbc implies -ibc
4255 if ( $rOpts->{'indent-spaced-block-comments'} ) {
4256 $rOpts->{'indent-block-comments'} = 1;
4259 # -bar cannot be used with -bl or -bli; arbitrarily keep -bar
4260 if ( $rOpts->{'opening-brace-always-on-right'} ) {
4262 if ( $rOpts->{'opening-brace-on-new-line'} ) {
4264 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
4265 'opening-brace-on-new-line' (-bl). Ignoring -bl.
4267 $rOpts->{'opening-brace-on-new-line'} = 0;
4269 if ( $rOpts->{'brace-left-and-indent'} ) {
4271 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
4272 '--brace-left-and-indent' (-bli). Ignoring -bli.
4274 $rOpts->{'brace-left-and-indent'} = 0;
4278 # it simplifies things if -bl is 0 rather than undefined
4279 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
4280 $rOpts->{'opening-brace-on-new-line'} = 0;
4283 if ( $rOpts->{'entab-leading-whitespace'} ) {
4284 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
4285 Warn("-et=n must use a positive integer; ignoring -et\n");
4286 $rOpts->{'entab-leading-whitespace'} = undef;
4289 # entab leading whitespace has priority over the older 'tabs' option
4290 if ( $rOpts->{'tabs'} ) {
4292 # The following warning could be added but would annoy a lot of
4293 # users who have a perltidyrc with both -t and -et=n. So instead
4294 # there is a note in the manual that -et overrides -t.
4295 ##Warn("-tabs and -et=n conflict; ignoring -tabs\n");
4296 $rOpts->{'tabs'} = 0;
4300 # set a default tabsize to be used in guessing the starting indentation
4301 # level if and only if this run does not use tabs and the old code does
4303 if ( $rOpts->{'default-tabsize'} ) {
4304 if ( $rOpts->{'default-tabsize'} < 0 ) {
4305 Warn("negative value of -dt, setting 0\n");
4306 $rOpts->{'default-tabsize'} = 0;
4308 if ( $rOpts->{'default-tabsize'} > 20 ) {
4309 Warn("unreasonably large value of -dt, reducing\n");
4310 $rOpts->{'default-tabsize'} = 20;
4314 $rOpts->{'default-tabsize'} = 8;
4317 # Check and clean up any sub-alias-list
4318 if ( $rOpts->{'sub-alias-list'} ) {
4319 my $sub_alias_string = $rOpts->{'sub-alias-list'};
4320 $sub_alias_string =~ s/,/ /g; # allow commas
4321 $sub_alias_string =~ s/^\s+//;
4322 $sub_alias_string =~ s/\s+$//;
4323 my @sub_alias_list = split /\s+/, $sub_alias_string;
4324 my @filtered_word_list = ('sub');
4327 # include 'sub' for later convenience
4329 foreach my $word (@sub_alias_list) {
4331 if ( $word !~ /^\w[\w\d]*$/ ) {
4332 Warn("unexpected sub alias '$word' - ignoring\n");
4334 if ( !$seen{$word} ) {
4336 push @filtered_word_list, $word;
4340 $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list;
4343 make_grep_alias_string($rOpts);
4345 # Turn on fuzzy-line-length unless this is an extrude run, as determined
4346 # by the -i and -ci settings. Otherwise blinkers can form (case b935)
4347 if ( !$rOpts->{'fuzzy-line-length'} ) {
4348 if ( $rOpts->{'maximum-line-length'} != 1
4349 || $rOpts->{'continuation-indentation'} != 0 )
4351 $rOpts->{'fuzzy-line-length'} = 1;
4355 # The freeze-whitespace option is currently a derived option which has its
4357 $rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'}
4358 && !$rOpts->{'delete-old-whitespace'};
4360 # Turn off certain options if whitespace is frozen
4361 # Note: vertical alignment will be automatically shut off
4362 if ( $rOpts->{'freeze-whitespace'} ) {
4363 $rOpts->{'logical-padding'} = 0;
4366 # Define $tabsize, the number of spaces per tab for use in
4367 # guessing the indentation of source lines with leading tabs.
4368 # Assume same as for this run if tabs are used , otherwise assume
4369 # a default value, typically 8
4371 $rOpts->{'entab-leading-whitespace'}
4372 ? $rOpts->{'entab-leading-whitespace'}
4373 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
4374 : $rOpts->{'default-tabsize'};
4376 } ## end sub check_options
4378 sub find_file_upwards {
4379 my ( $search_dir, $search_file ) = @_;
4381 $search_dir =~ s{/+$}{};
4382 $search_file =~ s{^/+}{};
4385 my $try_path = "$search_dir/$search_file";
4386 if ( -f $try_path ) {
4389 elsif ( $search_dir eq '/' ) {
4393 $search_dir = dirname($search_dir);
4397 # This return is for Perl-Critic.
4398 # We shouldn't get out of the while loop without a return
4400 } ## end sub find_file_upwards
4402 sub expand_command_abbreviations {
4404 # go through @ARGV and expand any abbreviations
4406 my ( $rexpansion, $rraw_options, $config_file ) = @_;
4408 # set a pass limit to prevent an infinite loop;
4409 # 10 should be plenty, but it may be increased to allow deeply
4410 # nested expansions.
4411 my $max_passes = 10;
4413 # keep looping until all expansions have been converted into actual
4415 foreach my $pass_count ( 0 .. $max_passes ) {
4417 my $abbrev_count = 0;
4419 # loop over each item in @ARGV..
4420 foreach my $word (@ARGV) {
4422 # convert any leading 'no-' to just 'no'
4423 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
4425 # if it is a dash flag (instead of a file name)..
4426 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
4431 # save the raw input for debug output in case of circular refs
4432 if ( $pass_count == 0 ) {
4433 push( @{$rraw_options}, $word );
4436 # recombine abbreviation and flag, if necessary,
4437 # to allow abbreviations with arguments such as '-vt=1'
4438 if ( $rexpansion->{ $abr . $flags } ) {
4439 $abr = $abr . $flags;
4440 $flags = EMPTY_STRING;
4443 # if we see this dash item in the expansion hash..
4444 if ( $rexpansion->{$abr} ) {
4447 # stuff all of the words that it expands to into the
4448 # new arg list for the next pass
4449 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
4450 next unless $abbrev; # for safety; shouldn't happen
4451 push( @new_argv, '--' . $abbrev . $flags );
4455 # not in expansion hash, must be actual long name
4457 push( @new_argv, $word );
4461 # not a dash item, so just save it for the next pass
4463 push( @new_argv, $word );
4465 } ## end of this pass
4467 # update parameter list @ARGV to the new one
4469 last if ( !$abbrev_count );
4471 # make sure we are not in an infinite loop
4472 if ( $pass_count == $max_passes ) {
4473 local $LIST_SEPARATOR = ')(';
4475 I'm tired. We seem to be in an infinite loop trying to expand aliases.
4476 Here are the raw options;
4479 my $num = @new_argv;
4482 After $max_passes passes here is ARGV
4488 After $max_passes passes ARGV has $num entries
4494 Please check your configuration file $config_file for circular-references.
4495 To deactivate it, use -npro.
4500 Program bug - circular-references in the %expansion hash, probably due to
4501 a recent program change.
4504 } ## end of check for circular references
4505 } ## end of loop over all passes
4507 } ## end sub expand_command_abbreviations
4509 # Debug routine -- this will dump the expansion hash
4510 sub dump_short_names {
4511 my $rexpansion = shift;
4513 List of short names. This list shows how all abbreviations are
4514 translated into other abbreviations and, eventually, into long names.
4515 New abbreviations may be defined in a .perltidyrc file.
4516 For a list of all long names, use perltidy --dump-long-names (-dln).
4517 --------------------------------------------------------------------------
4519 foreach my $abbrev ( sort keys %{$rexpansion} ) {
4520 my @list = @{ $rexpansion->{$abbrev} };
4521 print STDOUT "$abbrev --> @list\n";
4524 } ## end sub dump_short_names
4526 sub check_vms_filename {
4528 # given a valid filename (the perltidy input file)
4529 # create a modified filename and separator character
4532 # Contributed by Michael Cartmell
4534 my $filename = shift;
4535 my ( $base, $path ) = fileparse($filename);
4537 # remove explicit ; version
4538 $base =~ s/;-?\d*$//
4540 # remove explicit . version ie two dots in filename NB ^ escapes a dot
4541 or $base =~ s/( # begin capture $1
4542 (?:^|[^^])\. # match a dot not preceded by a caret
4543 (?: # followed by nothing
4545 .*[^^] # anything ending in a non caret
4548 \.-?\d*$ # match . version number
4551 # normalize filename, if there are no unescaped dots then append one
4552 $base .= '.' unless $base =~ /(?:^|[^^])\./;
4554 # if we don't already have an extension then we just append the extension
4555 my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_";
4556 return ( $path . $base, $separator );
4557 } ## end sub check_vms_filename
4561 # TODO: are these more standard names?
4562 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
4564 # Returns a string that determines what MS OS we are on.
4565 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
4566 # Returns blank string if not an MS system.
4567 # Original code contributed by: Yves Orton
4568 # We need to know this to decide where to look for config files
4570 my $rpending_complaint = shift;
4571 my $os = EMPTY_STRING;
4572 return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box?
4574 # Systems built from Perl source may not have Win32.pm
4575 # But probably have Win32::GetOSVersion() anyway so the
4576 # following line is not 'required':
4577 # return $os unless eval('require Win32');
4579 # Use the standard API call to determine the version
4580 my ( $undef, $major, $minor, $build, $id );
4582 ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion();
4585 if ( !$ok && DEVEL_MODE ) {
4586 Fault("Could not cal Win32::GetOSVersion(): $EVAL_ERROR\n");
4590 # NAME ID MAJOR MINOR
4591 # Windows NT 4 2 4 0
4592 # Windows 2000 2 5 0
4594 # Windows Server 2003 2 5 2
4596 return "win32s" unless $id; # If id==0 then its a win32s box.
4597 $os = { # Magic numbers from MSDN
4598 # documentation of GetOSVersion
4605 0 => "2000", # or NT 4, see below
4612 # If $os is undefined, the above code is out of date. Suggested updates
4614 unless ( defined $os ) {
4617 # Deactivated this message 20180322 because it was needlessly
4618 # causing some test scripts to fail. Need help from someone
4619 # with expertise in Windows to decide what is possible with windows.
4620 ${$rpending_complaint} .= <<EOS if (0);
4621 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
4622 We won't be able to look for a system-wide config file.
4626 # Unfortunately the logic used for the various versions isn't so clever..
4627 # so we have to handle an outside case.
4628 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
4629 } ## end sub Win_OS_Type
4633 ( $OSNAME !~ /win32|dos/i )
4634 && ( $OSNAME ne 'VMS' )
4635 && ( $OSNAME ne 'OS2' )
4636 && ( $OSNAME ne 'MacOS' );
4639 sub look_for_Windows {
4641 # determine Windows sub-type and location of
4642 # system-wide configuration files
4643 my $rpending_complaint = shift;
4644 my $is_Windows = ( $OSNAME =~ /win32|dos/i );
4646 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
4647 return ( $is_Windows, $Windows_type );
4648 } ## end sub look_for_Windows
4650 sub find_config_file {
4652 # look for a .perltidyrc configuration file
4653 # For Windows also look for a file named perltidy.ini
4654 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
4655 $rpending_complaint )
4658 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
4660 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
4663 ${$rconfig_file_chatter} .= " $OSNAME\n";
4666 # sub to check file existence and record all tests
4667 my $exists_config_file = sub {
4668 my $config_file = shift;
4669 return 0 unless $config_file;
4670 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
4671 return -f $config_file;
4674 # Sub to search upward for config file
4675 my $resolve_config_file = sub {
4677 # resolve <dir>/.../<file>, meaning look upwards from directory
4678 my $config_file = shift;
4680 if ( my ( $start_dir, $search_file ) =
4681 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
4683 ${$rconfig_file_chatter} .=
4684 "# Searching Upward: $config_file\n";
4685 $start_dir = '.' if !$start_dir;
4686 $start_dir = Cwd::realpath($start_dir);
4687 if ( my $found_file =
4688 find_file_upwards( $start_dir, $search_file ) )
4690 $config_file = $found_file;
4691 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
4695 return $config_file;
4700 # look in current directory first
4701 $config_file = ".perltidyrc";
4702 return $config_file if $exists_config_file->($config_file);
4704 $config_file = "perltidy.ini";
4705 return $config_file if $exists_config_file->($config_file);
4708 # Default environment vars.
4709 my @envs = qw(PERLTIDY HOME);
4711 # Check the NT/2k/XP locations, first a local machine def, then a
4713 push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
4715 # Now go through the environment ...
4716 foreach my $var (@envs) {
4717 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
4718 if ( defined( $ENV{$var} ) ) {
4719 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
4721 # test ENV{ PERLTIDY } as file:
4722 if ( $var eq 'PERLTIDY' ) {
4723 $config_file = "$ENV{$var}";
4724 $config_file = $resolve_config_file->($config_file);
4725 return $config_file if $exists_config_file->($config_file);
4728 # test ENV as directory:
4729 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
4730 $config_file = $resolve_config_file->($config_file);
4731 return $config_file if $exists_config_file->($config_file);
4734 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
4735 $config_file = $resolve_config_file->($config_file);
4736 return $config_file if $exists_config_file->($config_file);
4740 ${$rconfig_file_chatter} .= "\n";
4744 # then look for a system-wide definition
4745 # where to look varies with OS
4748 if ($Windows_type) {
4749 my ( $os, $system, $allusers ) =
4750 Win_Config_Locs( $rpending_complaint, $Windows_type );
4752 # Check All Users directory, if there is one.
4753 # i.e. C:\Documents and Settings\User\perltidy.ini
4756 $config_file = catfile( $allusers, ".perltidyrc" );
4757 return $config_file if $exists_config_file->($config_file);
4759 $config_file = catfile( $allusers, "perltidy.ini" );
4760 return $config_file if $exists_config_file->($config_file);
4763 # Check system directory.
4764 # retain old code in case someone has been able to create
4765 # a file with a leading period.
4766 $config_file = catfile( $system, ".perltidyrc" );
4767 return $config_file if $exists_config_file->($config_file);
4769 $config_file = catfile( $system, "perltidy.ini" );
4770 return $config_file if $exists_config_file->($config_file);
4774 # Place to add customization code for other systems
4775 elsif ( $OSNAME eq 'OS2' ) {
4777 elsif ( $OSNAME eq 'MacOS' ) {
4779 elsif ( $OSNAME eq 'VMS' ) {
4782 # Assume some kind of Unix
4785 $config_file = "/usr/local/etc/perltidyrc";
4786 return $config_file if $exists_config_file->($config_file);
4788 $config_file = "/etc/perltidyrc";
4789 return $config_file if $exists_config_file->($config_file);
4792 # Couldn't find a config file
4794 } ## end sub find_config_file
4796 sub Win_Config_Locs {
4798 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
4799 # or undef if its not a win32 OS. In list context returns OS, System
4800 # Directory, and All Users Directory. All Users will be empty on a
4801 # 9x/Me box. Contributed by: Yves Orton.
4803 my ( $rpending_complaint, $os ) = @_;
4804 if ( !$os ) { $os = Win_OS_Type(); }
4808 my $system = EMPTY_STRING;
4809 my $allusers = EMPTY_STRING;
4811 if ( $os =~ /9[58]|Me/ ) {
4812 $system = "C:/Windows";
4814 elsif ( $os =~ /NT|XP|200?/ ) {
4815 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
4818 ? "C:/WinNT/profiles/All Users/"
4819 : "C:/Documents and Settings/All Users/";
4823 # This currently would only happen on a win32s computer. I don't have
4824 # one to test, so I am unsure how to proceed. Suggestions welcome!
4825 ${$rpending_complaint} .=
4826 "I dont know a sensible place to look for config files on an $os system.\n";
4829 return wantarray ? ( $os, $system, $allusers ) : $os;
4830 } ## end sub Win_Config_Locs
4832 sub dump_config_file {
4833 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
4834 print STDOUT "${$rconfig_file_chatter}";
4836 print STDOUT "# Dump of file: '$config_file'\n";
4837 while ( my $line = $fh->getline() ) { print STDOUT $line }
4838 my $ok = eval { $fh->close(); 1 };
4839 if ( !$ok && DEVEL_MODE ) {
4840 Fault("Could not close file handle(): $EVAL_ERROR\n");
4844 print STDOUT "# ...no config file found\n";
4847 } ## end sub dump_config_file
4849 sub read_config_file {
4851 my ( $fh, $config_file, $rexpansion ) = @_;
4852 my @config_list = ();
4854 # file is bad if non-empty $death_message is returned
4855 my $death_message = EMPTY_STRING;
4859 my $opening_brace_line;
4860 while ( my $line = $fh->getline() ) {
4863 ( $line, $death_message ) =
4864 strip_comment( $line, $config_file, $line_no );
4865 last if ($death_message);
4867 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
4872 # Look for complete or partial abbreviation definition of the form
4873 # name { body } or name { or name { body
4874 # See rules in perltidy's perldoc page
4875 # Section: Other Controls - Creating a new abbreviation
4876 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
4877 my $oldname = $name;
4878 ( $name, $body ) = ( $2, $3 );
4880 # Cannot start new abbreviation unless old abbreviation is complete
4881 last if ($opening_brace_line);
4883 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
4885 # handle a new alias definition
4886 if ( $rexpansion->{$name} ) {
4887 local $LIST_SEPARATOR = ')(';
4888 my @names = sort keys %{$rexpansion};
4890 "Here is a list of all installed aliases\n(@names)\n"
4891 . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
4894 $rexpansion->{$name} = [];
4897 # leading opening braces not allowed
4898 elsif ( $line =~ /^{/ ) {
4899 $opening_brace_line = undef;
4901 "Unexpected '{' at line $line_no in config file '$config_file'\n";
4905 # Look for abbreviation closing: body } or }
4906 elsif ( $line =~ /^(.*)?\}$/ ) {
4908 if ($opening_brace_line) {
4909 $opening_brace_line = undef;
4913 "Unexpected '}' at line $line_no in config file '$config_file'\n";
4918 # Now store any parameters
4921 my ( $rbody_parts, $msg ) = parse_args($body);
4923 $death_message = <<EOM;
4924 Error reading file '$config_file' at line number $line_no.
4926 Please fix this line or use -npro to avoid reading this file
4933 # remove leading dashes if this is an alias
4934 foreach ( @{$rbody_parts} ) { s/^\-+//; }
4935 push @{ $rexpansion->{$name} }, @{$rbody_parts};
4938 push( @config_list, @{$rbody_parts} );
4943 if ($opening_brace_line) {
4945 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
4947 my $ok = eval { $fh->close(); 1 };
4948 if ( !$ok && DEVEL_MODE ) {
4949 Fault("Could not close file handle(): $EVAL_ERROR\n");
4951 return ( \@config_list, $death_message );
4952 } ## end sub read_config_file
4956 # Strip any comment from a command line
4957 my ( $instr, $config_file, $line_no ) = @_;
4958 my $msg = EMPTY_STRING;
4960 # check for full-line comment
4961 if ( $instr =~ /^\s*#/ ) {
4962 return ( EMPTY_STRING, $msg );
4965 # nothing to do if no comments
4966 if ( $instr !~ /#/ ) {
4967 return ( $instr, $msg );
4970 # handle case of no quotes
4971 elsif ( $instr !~ /['"]/ ) {
4973 # We now require a space before the # of a side comment
4974 # this allows something like:
4976 # Otherwise, it would have to be quoted:
4978 $instr =~ s/\s+\#.*$//;
4979 return ( $instr, $msg );
4982 # handle comments and quotes
4983 my $outstr = EMPTY_STRING;
4984 my $quote_char = EMPTY_STRING;
4987 # looking for ending quote character
4989 if ( $instr =~ /\G($quote_char)/gc ) {
4990 $quote_char = EMPTY_STRING;
4993 elsif ( $instr =~ /\G(.)/gc ) {
4997 # error..we reached the end without seeing the ending quote char
5000 Error reading file $config_file at line number $line_no.
5001 Did not see ending quote character <$quote_char> in this text:
5003 Please fix this line or use -npro to avoid reading this file
5009 # accumulating characters and looking for start of a quoted string
5011 if ( $instr =~ /\G([\"\'])/gc ) {
5016 # Note: not yet enforcing the space-before-hash rule for side
5017 # comments if the parameter is quoted.
5018 elsif ( $instr =~ /\G#/gc ) {
5021 elsif ( $instr =~ /\G(.)/gc ) {
5029 return ( $outstr, $msg );
5030 } ## end sub strip_comment
5034 # Parse a command string containing multiple string with possible
5035 # quotes, into individual commands. It might look like this, for example:
5037 # -wba=" + - " -some-thing -wbb='. && ||'
5039 # There is no need, at present, to handle escaped quote characters.
5040 # (They are not perltidy tokens, so needn't be in strings).
5043 my @body_parts = ();
5044 my $quote_char = EMPTY_STRING;
5045 my $part = EMPTY_STRING;
5046 my $msg = EMPTY_STRING;
5048 # Check for external call with undefined $body - added to fix
5049 # github issue Perl-Tidy-Sweetened issue #23
5050 if ( !defined($body) ) { $body = EMPTY_STRING }
5054 # looking for ending quote character
5056 if ( $body =~ /\G($quote_char)/gc ) {
5057 $quote_char = EMPTY_STRING;
5059 elsif ( $body =~ /\G(.)/gc ) {
5063 # error..we reached the end without seeing the ending quote char
5065 if ( length($part) ) { push @body_parts, $part; }
5067 Did not see ending quote character <$quote_char> in this text:
5074 # accumulating characters and looking for start of a quoted string
5076 if ( $body =~ /\G([\"\'])/gc ) {
5079 elsif ( $body =~ /\G(\s+)/gc ) {
5080 if ( length($part) ) { push @body_parts, $part; }
5081 $part = EMPTY_STRING;
5083 elsif ( $body =~ /\G(.)/gc ) {
5087 if ( length($part) ) { push @body_parts, $part; }
5092 return ( \@body_parts, $msg );
5093 } ## end sub parse_args
5095 sub dump_long_names {
5099 # Command line long names (passed to GetOptions)
5100 #--------------------------------------------------
5101 # here is a summary of the Getopt codes:
5102 # <none> does not take an argument
5103 # =s takes a mandatory string
5104 # :s takes an optional string
5105 # =i takes a mandatory integer
5106 # :i takes an optional integer
5107 # ! does not take an argument and may be negated
5108 # i.e., -foo and -nofoo are allowed
5109 # a double dash signals the end of the options list
5111 #--------------------------------------------------
5114 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
5116 } ## end sub dump_long_names
5120 print STDOUT "Default command line options:\n";
5121 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
5125 sub readable_options {
5127 # return options for this run as a string which could be
5128 # put in a perltidyrc file
5129 my ( $rOpts, $roption_string ) = @_;
5131 my $rGetopt_flags = \%Getopt_flags;
5132 my $readable_options = "# Final parameter set for this run.\n";
5133 $readable_options .=
5134 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
5135 foreach my $opt ( @{$roption_string} ) {
5136 my $flag = EMPTY_STRING;
5137 if ( $opt =~ /(.*)(!|=.*)$/ ) {
5141 if ( defined( $rOpts->{$opt} ) ) {
5142 $rGetopt_flags->{$opt} = $flag;
5145 foreach my $key ( sort keys %{$rOpts} ) {
5146 my $flag = $rGetopt_flags->{$key};
5147 my $value = $rOpts->{$key};
5149 my $suffix = EMPTY_STRING;
5151 if ( $flag =~ /^=/ ) {
5152 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
5153 $suffix = "=" . $value;
5155 elsif ( $flag =~ /^!/ ) {
5156 $prefix .= "no" unless ($value);
5161 $readable_options .=
5162 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
5165 $readable_options .= $prefix . $key . $suffix . "\n";
5167 return $readable_options;
5168 } ## end sub readable_options
5171 print STDOUT <<"EOM";
5172 This is perltidy, v$VERSION
5174 Copyright 2000-2022, Steve Hancock
5176 Perltidy is free software and may be copied under the terms of the GNU
5177 General Public License, which is included in the distribution files.
5179 Complete documentation for perltidy can be found using 'man perltidy'
5180 or on the internet at http://perltidy.sourceforge.net.
5183 } ## end sub show_version
5188 This is perltidy version $VERSION, a perl script indenter. Usage:
5190 perltidy [ options ] file1 file2 file3 ...
5191 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
5192 perltidy [ options ] file1 -o outfile
5193 perltidy [ options ] file1 -st >outfile
5194 perltidy [ options ] <infile >outfile
5196 Options have short and long forms. Short forms are shown; see
5197 man pages for long forms. Note: '=s' indicates a required string,
5198 and '=n' indicates a required integer.
5202 -o=file name of the output file (only if single input file)
5203 -oext=s change output extension from 'tdy' to s
5204 -opath=path change path to be 'path' for output files
5205 -b backup original to .bak and modify file in-place
5206 -bext=s change default backup extension from 'bak' to s
5207 -q deactivate error messages (for running under editor)
5208 -w include non-critical warning messages in the .ERR error output
5209 -log save .LOG file, which has useful diagnostics
5210 -f force perltidy to read a binary file
5211 -g like -log but writes more detailed .LOG file, for debugging scripts
5212 -opt write the set of options actually used to a .LOG file
5213 -npro ignore .perltidyrc configuration command file
5214 -pro=file read configuration commands from file instead of .perltidyrc
5215 -st send output to standard output, STDOUT
5216 -se send all error output to standard error output, STDERR
5217 -v display version number to standard output and quit
5220 -i=n use n columns per indentation level (default n=4)
5221 -t tabs: use one tab character per indentation level, not recommended
5222 -nt no tabs: use n spaces per indentation level (default)
5223 -et=n entab leading whitespace n spaces per tab; not recommended
5224 -io "indent only": just do indentation, no other formatting.
5225 -sil=n set starting indentation level to n; use if auto detection fails
5226 -ole=s specify output line ending (s=dos or win, mac, unix)
5227 -ple keep output line endings same as input (input must be filename)
5230 -fws freeze whitespace; this disables all whitespace changes
5231 and disables the following switches:
5232 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
5233 -bbt same as -bt but for code block braces; same as -bt if not given
5234 -bbvt block braces vertically tight; use with -bl or -bli
5235 -bbvtl=s make -bbvt to apply to selected list of block types
5236 -pt=n paren tightness (n=0, 1 or 2)
5237 -sbt=n square bracket tightness (n=0, 1, or 2)
5238 -bvt=n brace vertical tightness,
5239 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
5240 -pvt=n paren vertical tightness (see -bvt for n)
5241 -sbvt=n square bracket vertical tightness (see -bvt for n)
5242 -bvtc=n closing brace vertical tightness:
5243 n=(0=open, 1=sometimes close, 2=always close)
5244 -pvtc=n closing paren vertical tightness, see -bvtc for n.
5245 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
5246 -ci=n sets continuation indentation=n, default is n=2 spaces
5247 -lp line up parentheses, brackets, and non-BLOCK braces
5248 -sfs add space before semicolon in for( ; ; )
5249 -aws allow perltidy to add whitespace (default)
5250 -dws delete all old non-essential whitespace
5251 -icb indent closing brace of a code block
5252 -cti=n closing indentation of paren, square bracket, or non-block brace:
5253 n=0 none, =1 align with opening, =2 one full indentation level
5254 -icp equivalent to -cti=2
5255 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
5256 -wrs=s want space right of tokens in string;
5257 -sts put space before terminal semicolon of a statement
5258 -sak=s put space between keywords given in s and '(';
5259 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
5262 -fnl freeze newlines; this disables all line break changes
5263 and disables the following switches:
5264 -anl add newlines; ok to introduce new line breaks
5265 -bbs add blank line before subs and packages
5266 -bbc add blank line before block comments
5267 -bbb add blank line between major blocks
5268 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
5269 -mbl=n maximum consecutive blank lines to output (default=1)
5270 -ce cuddled else; use this style: '} else {'
5271 -cb cuddled blocks (other than 'if-elsif-else')
5272 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
5273 -dnl delete old newlines (default)
5274 -l=n maximum line length; default n=80
5275 -bl opening brace on new line
5276 -sbl opening sub brace on new line. value of -bl is used if not given.
5277 -bli opening brace on new line and indented
5278 -bar opening brace always on right, even for long clauses
5279 -vt=n vertical tightness (requires -lp); n controls break after opening
5280 token: 0=never 1=no break if next line balanced 2=no break
5281 -vtc=n vertical tightness of closing container; n controls if closing
5282 token starts new line: 0=always 1=not unless list 1=never
5283 -wba=s want break after tokens in string; i.e. wba=': .'
5284 -wbb=s want break before tokens in string
5285 -wn weld nested: combines opening and closing tokens when both are adjacent
5286 -wnxl=s weld nested exclusion list: provides some control over the types of
5287 containers which can be welded
5289 Following Old Breakpoints
5290 -kis keep interior semicolons. Allows multiple statements per line.
5291 -boc break at old comma breaks: turns off all automatic list formatting
5292 -bol break at old logical breakpoints: or, and, ||, && (default)
5293 -bom break at old method call breakpoints: ->
5294 -bok break at old list keyword breakpoints such as map, sort (default)
5295 -bot break at old conditional (ternary ?:) operator breakpoints (default)
5296 -boa break at old attribute breakpoints
5297 -cab=n break at commas after a comma-arrow (=>):
5298 n=0 break at all commas after =>
5299 n=1 stable: break unless this breaks an existing one-line container
5300 n=2 break only if a one-line container cannot be formed
5301 n=3 do not treat commas after => specially at all
5304 -ibc indent block comments (default)
5305 -isbc indent spaced block comments; may indent unless no leading space
5306 -msc=n minimum desired spaces to side comment, default 4
5307 -fpsc=n fix position for side comments; default 0;
5308 -csc add or update closing side comments after closing BLOCK brace
5309 -dcsc delete closing side comments created by a -csc command
5310 -cscp=s change closing side comment prefix to be other than '## end'
5311 -cscl=s change closing side comment to apply to selected list of blocks
5312 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
5313 -csct=n maximum number of columns of appended text, default n=20
5314 -cscw causes warning if old side comment is overwritten with -csc
5316 -sbc use 'static block comments' identified by leading '##' (default)
5317 -sbcp=s change static block comment identifier to be other than '##'
5318 -osbc outdent static block comments
5320 -ssc use 'static side comments' identified by leading '##' (default)
5321 -sscp=s change static side comment identifier to be other than '##'
5323 Delete selected text
5324 -dac delete all comments AND pod
5325 -dbc delete block comments
5326 -dsc delete side comments
5329 Send selected text to a '.TEE' file
5330 -tac tee all comments AND pod
5331 -tbc tee block comments
5332 -tsc tee side comments
5336 -olq outdent long quoted strings (default)
5337 -olc outdent a long block comment line
5338 -ola outdent statement labels
5339 -okw outdent control keywords (redo, next, last, goto, return)
5340 -okwl=s specify alternative keywords for -okw command
5343 -mft=n maximum fields per table; default n=40
5344 -x do not format lines before hash-bang line (i.e., for VMS)
5345 -asc allows perltidy to add a ';' when missing (default)
5346 -dsm allows perltidy to delete an unnecessary ';' (default)
5348 Combinations of other parameters
5349 -gnu attempt to follow GNU Coding Standards as applied to perl
5350 -mangle remove as many newlines as possible (but keep comments and pods)
5351 -extrude insert as many newlines as possible
5353 Dump and die, debugging
5354 -dop dump options used in this run to standard output and quit
5355 -ddf dump default options to standard output and quit
5356 -dsn dump all option short names to standard output and quit
5357 -dln dump option long names to standard output and quit
5358 -dpro dump whatever configuration file is in effect to standard output
5359 -dtt dump all token types to standard output and quit
5362 -html write an html file (see 'man perl2web' for many options)
5363 Note: when -html is used, no indentation or formatting are done.
5364 Hint: try perltidy -html -css=mystyle.css filename.pl
5365 and edit mystyle.css to change the appearance of filename.html.
5366 -nnn gives line numbers
5367 -pre only writes out <pre>..</pre> code section
5368 -toc places a table of contents to subs at the top (default)
5369 -pod passes pod text through pod2html (default)
5370 -frm write html as a frame (3 files)
5371 -text=s extra extension for table of contents if -frm, default='toc'
5372 -sext=s extra extension for file content if -frm, default='src'
5374 A prefix of "n" negates short form toggle switches, and a prefix of "no"
5375 negates the long forms. For example, -nasc means don't add missing
5378 If you are unable to see this entire text, try "perltidy -h | more"
5379 For more detailed information, and additional options, try "man perltidy",
5380 or go to the perltidy home page at http://perltidy.sourceforge.net