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 YYMMDD 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 is continually bumped along
112 # at significant points during development. If it ever reaches 99 then the
113 # Release version must be bumped, and it is probably past time for a
116 $VERSION = '20220613';
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 eval { require File::Spec };
321 $missing_file_spec = $EVAL_ERROR;
326 # concatenate a path and file basename
327 # returns undef in case of error
331 # use File::Spec if we can
332 unless ($missing_file_spec) {
333 return File::Spec->catfile(@parts);
336 # Perl 5.004 systems may not have File::Spec so we'll make
337 # a simple try. We assume File::Basename is available.
338 # return if not successful.
339 my $name = pop @parts;
340 my $path = join '/', @parts;
341 my $test_file = $path . $name;
342 my ( $test_name, $test_path ) = fileparse($test_file);
343 return $test_file if ( $test_name eq $name );
344 return if ( $OSNAME eq 'VMS' );
346 # this should work at least for Windows and Unix:
347 $test_file = $path . '/' . $name;
348 ( $test_name, $test_path ) = fileparse($test_file);
349 return $test_file if ( $test_name eq $name );
352 } ## end closure for sub catfile
354 # Here is a map of the flow of data from the input source to the output
357 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
358 # input groups output
359 # lines tokens lines of lines lines
362 # The names correspond to the package names responsible for the unit processes.
364 # The overall process is controlled by the "main" package.
366 # LineSource is the stream of input lines
368 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
369 # if necessary. A token is any section of the input line which should be
370 # manipulated as a single entity during formatting. For example, a single
371 # ',' character is a token, and so is an entire side comment. It handles
372 # the complexities of Perl syntax, such as distinguishing between '<<' as
373 # a shift operator and as a here-document, or distinguishing between '/'
374 # as a divide symbol and as a pattern delimiter.
376 # Formatter inserts and deletes whitespace between tokens, and breaks
377 # sequences of tokens at appropriate points as output lines. It bases its
378 # decisions on the default rules as modified by any command-line options.
380 # VerticalAligner collects groups of lines together and tries to line up
381 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
383 # FileWriter simply writes lines to the output stream.
385 # The Logger package, not shown, records significant events and warning
386 # messages. It writes a .LOG file, which may be saved with a
387 # '-log' or a '-g' flag.
394 # Bump Warn_count only: it is essential to bump the count on all warnings, even
395 # if no message goes out, so that the correct exit status is set.
396 sub Warn_count_bump { $Warn_count++; return }
398 # Output Warn message only
399 sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return }
401 # Output Warn message and bump Warn count
402 sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
409 # true if $string is in Perl's internal character mode
410 # (also called the 'upgraded form', or UTF8=1)
411 # false if $string is in Perl's internal byte mode
413 # This function isolates the call to Perl's internal function
414 # utf8::is_utf8() which is true for strings represented in an 'upgraded
415 # form'. It is available after Perl version 5.8.
416 # See https://perldoc.perl.org/Encode.
417 # See also comments in Carp.pm and other modules using this function
419 return 1 if ( utf8::is_utf8($string) );
421 } ## end sub is_char_mode
429 destination => undef,
438 dump_options => undef,
439 dump_options_type => undef,
440 dump_getopt_flags => undef,
441 dump_options_category => undef,
442 dump_options_range => undef,
443 dump_abbreviations => undef,
448 # Status information which can be returned for diagnostic purposes.
449 # This is intended for testing and subject to change.
451 # List of "key => value" hash entries:
453 # Some relevant user input parameters for convenience:
454 # opt_format => value of --format: 'tidy', 'html', or 'user'
455 # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
456 # opt_encode_output => value of -eos flag: 'eos' or 'neos'
457 # opt_max_iterations => value of --iterations=n
459 # file_count => number of files processed in this call
461 # If multiple files are processed, then the following values will be for
462 # the last file only:
464 # input_name => name of the input stream
465 # output_name => name of the output stream
467 # The following two variables refer to Perl's two internal string modes,
468 # and have the values 0 for 'byte' mode and 1 for 'char' mode:
469 # char_mode_source => true if source is in 'char' mode. Will be false
470 # unless we received a source string ref with utf8::is_utf8() set.
471 # char_mode_used => true if text processed by perltidy in 'char' mode.
472 # Normally true for text identified as utf8, otherwise false.
474 # This tells if Unicode::GCString was used
475 # gcs_used => true if -gcs and Unicode::GCString found & used
477 # These variables tell what utf8 decoding/encoding was done:
478 # input_decoded_as => non-blank if perltidy decoded the source text
479 # output_encoded_as => non-blank if perltidy encoded before return
481 # These variables are related to iterations and convergence testing:
482 # iteration_count => number of iterations done
483 # ( can be from 1 to opt_max_iterations )
484 # converged => true if stopped on convergence
485 # ( can only happen if opt_max_iterations > 1 )
486 # blinking => true if stopped on blinking states
487 # ( i.e., unstable formatting, should not happen )
492 opt_format => EMPTY_STRING,
493 opt_encoding => EMPTY_STRING,
494 opt_encode_output => EMPTY_STRING,
495 opt_max_iterations => EMPTY_STRING,
497 input_name => EMPTY_STRING,
498 output_name => EMPTY_STRING,
499 char_mode_source => 0,
501 input_decoded_as => EMPTY_STRING,
502 output_encoded_as => EMPTY_STRING,
504 iteration_count => 0,
509 # Fix for issue git #57
512 # don't overwrite callers ARGV
514 local *STDERR = *STDERR;
516 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
517 local $LIST_SEPARATOR = ')(';
518 my @good_keys = sort keys %defaults;
519 @bad_keys = sort @bad_keys;
521 ------------------------------------------------------------------------
522 Unknown perltidy parameter : (@bad_keys)
523 perltidy only understands : (@good_keys)
524 ------------------------------------------------------------------------
529 my $get_hash_ref = sub {
531 my $hash_ref = $input_hash{$key};
532 if ( defined($hash_ref) ) {
533 unless ( ref($hash_ref) eq 'HASH' ) {
534 my $what = ref($hash_ref);
536 $what ? "but is ref to $what" : "but is not a reference";
538 ------------------------------------------------------------------------
539 error in call to perltidy:
540 -$key must be reference to HASH $but_is
541 ------------------------------------------------------------------------
548 %input_hash = ( %defaults, %input_hash );
549 my $argv = $input_hash{'argv'};
550 my $destination_stream = $input_hash{'destination'};
551 my $errorfile_stream = $input_hash{'errorfile'};
552 my $logfile_stream = $input_hash{'logfile'};
553 my $teefile_stream = $input_hash{'teefile'};
554 my $debugfile_stream = $input_hash{'debugfile'};
555 my $perltidyrc_stream = $input_hash{'perltidyrc'};
556 my $source_stream = $input_hash{'source'};
557 my $stderr_stream = $input_hash{'stderr'};
558 my $user_formatter = $input_hash{'formatter'};
559 my $prefilter = $input_hash{'prefilter'};
560 my $postfilter = $input_hash{'postfilter'};
562 if ($stderr_stream) {
563 ( $fh_stderr, my $stderr_file ) =
564 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
567 ------------------------------------------------------------------------
568 Unable to redirect STDERR to $stderr_stream
569 Please check value of -stderr in call to perltidy
570 ------------------------------------------------------------------------
575 $fh_stderr = *STDERR;
580 if ($flag) { goto ERROR_EXIT }
581 else { goto NORMAL_EXIT }
582 croak "unexpectd return to Exit";
589 croak "unexpected return to Die";
595 # Evaluate the MD5 sum for a string
596 # Patch for [rt.cpan.org #88020]
597 # Use utf8::encode since md5_hex() only operates on bytes.
598 # my $digest = md5_hex( utf8::encode($sink_buffer) );
600 # Note added 20180114: the above patch did not work correctly. I'm not
601 # sure why. But switching to the method recommended in the Perl 5
602 # documentation for Encode worked. According to this we can either use
603 # $octets = encode_utf8($string) or equivalently
604 # $octets = encode("utf8",$string)
605 # and then calculate the checksum. So:
606 my $octets = Encode::encode( "utf8", $buf );
607 my $digest = md5_hex($octets);
611 # extract various dump parameters
612 my $dump_options_type = $input_hash{'dump_options_type'};
613 my $dump_options = $get_hash_ref->('dump_options');
614 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
615 my $dump_options_category = $get_hash_ref->('dump_options_category');
616 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
617 my $dump_options_range = $get_hash_ref->('dump_options_range');
619 # validate dump_options_type
620 if ( defined($dump_options) ) {
621 unless ( defined($dump_options_type) ) {
622 $dump_options_type = 'perltidyrc';
624 if ( $dump_options_type ne 'perltidyrc'
625 && $dump_options_type ne 'full' )
628 ------------------------------------------------------------------------
629 Please check value of -dump_options_type in call to perltidy;
630 saw: '$dump_options_type'
631 expecting: 'perltidyrc' or 'full'
632 ------------------------------------------------------------------------
638 $dump_options_type = EMPTY_STRING;
641 if ($user_formatter) {
643 # if the user defines a formatter, there is no output stream,
644 # but we need a null stream to keep coding simple
645 $destination_stream = Perl::Tidy::DevNull->new();
648 # see if ARGV is overridden
649 if ( defined($argv) ) {
651 my $rargv = ref $argv;
652 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
656 if ( $rargv eq 'ARRAY' ) {
661 ------------------------------------------------------------------------
662 Please check value of -argv in call to perltidy;
663 it must be a string or ref to ARRAY but is: $rargv
664 ------------------------------------------------------------------------
671 my ( $rargv_str, $msg ) = parse_args($argv);
674 Error parsing this string passed to to perltidy with 'argv':
678 @ARGV = @{$rargv_str};
682 my $rpending_complaint;
683 ${$rpending_complaint} = EMPTY_STRING;
684 my $rpending_logfile_message;
685 ${$rpending_logfile_message} = EMPTY_STRING;
687 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
689 # VMS file names are restricted to a 40.40 format, so we append _tdy
690 # instead of .tdy, etc. (but see also sub check_vms_filename)
693 if ( $OSNAME eq 'VMS' ) {
699 $dot_pattern = '\.'; # must escape for use in regex
702 #---------------------------------------------------------------
703 # get command line options
704 #---------------------------------------------------------------
705 my ( $rOpts, $config_file, $rraw_options, $roption_string,
706 $rexpansion, $roption_category, $roption_range )
707 = process_command_line(
708 $perltidyrc_stream, $is_Windows, $Windows_type,
709 $rpending_complaint, $dump_options_type,
713 grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
715 #---------------------------------------------------------------
716 # Handle requests to dump information
717 #---------------------------------------------------------------
719 # return or exit immediately after all dumps
722 # Getopt parameters and their flags
723 if ( defined($dump_getopt_flags) ) {
725 foreach my $op ( @{$roption_string} ) {
727 my $flag = EMPTY_STRING;
734 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
738 $dump_getopt_flags->{$opt} = $flag;
742 if ( defined($dump_options_category) ) {
744 %{$dump_options_category} = %{$roption_category};
747 if ( defined($dump_options_range) ) {
749 %{$dump_options_range} = %{$roption_range};
752 if ( defined($dump_abbreviations) ) {
754 %{$dump_abbreviations} = %{$rexpansion};
757 if ( defined($dump_options) ) {
759 %{$dump_options} = %{$rOpts};
762 Exit(0) if ($quit_now);
764 # make printable string of options for this run as possible diagnostic
765 my $readable_options = readable_options( $rOpts, $roption_string );
767 # dump from command line
768 if ( $rOpts->{'dump-options'} ) {
769 print STDOUT $readable_options;
773 #---------------------------------------------------------------
774 # check parameters and their interactions
775 #---------------------------------------------------------------
777 check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
779 if ($user_formatter) {
780 $rOpts->{'format'} = 'user';
783 # there must be one entry here for every possible format
784 my %default_file_extension = (
787 user => EMPTY_STRING,
790 $rstatus->{'opt_format'} = $rOpts->{'format'};
791 $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
792 $rstatus->{'opt_encode_output'} =
793 $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
795 # be sure we have a valid output format
796 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
797 my $formats = join SPACE,
798 sort map { "'" . $_ . "'" } keys %default_file_extension;
799 my $fmt = $rOpts->{'format'};
800 Die("-format='$fmt' but must be one of: $formats\n");
803 my $output_extension = make_extension( $rOpts->{'output-file-extension'},
804 $default_file_extension{ $rOpts->{'format'} }, $dot );
806 # If the backup extension contains a / character then the backup should
807 # be deleted when the -b option is used. On older versions of
808 # perltidy this will generate an error message due to an illegal
811 # A backup file will still be generated but will be deleted
812 # at the end. If -bext='/' then this extension will be
813 # the default 'bak'. Otherwise it will be whatever characters
814 # remains after all '/' characters are removed. For example:
815 # -bext extension slashes
819 # '/dev/null' devnull 2 (Currently not allowed)
820 my $bext = $rOpts->{'backup-file-extension'};
821 my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
823 # At present only one forward slash is allowed. In the future multiple
824 # slashes may be allowed to allow for other options
825 if ( $delete_backup > 1 ) {
826 Die("-bext=$bext contains more than one '/'\n");
829 my $backup_extension =
830 make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
832 my $html_toc_extension =
833 make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
835 my $html_src_extension =
836 make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
838 # check for -b option;
839 # silently ignore unless beautify mode
840 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
841 && $rOpts->{'format'} eq 'tidy';
843 # Turn off -b with warnings in case of conflicts with other options.
844 # NOTE: Do this silently, without warnings, if there is a source or
845 # destination stream, or standard output is used. This is because the -b
846 # flag may have been in a .perltidyrc file and warnings break
847 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
848 if ($in_place_modify) {
849 if ( $rOpts->{'standard-output'}
850 || $destination_stream
851 || ref $source_stream
852 || $rOpts->{'outfile'}
853 || defined( $rOpts->{'output-path'} ) )
855 $in_place_modify = 0;
859 # Turn off assert-tidy and assert-untidy unless we are tidying files
860 if ( $rOpts->{'format'} ne 'tidy' ) {
861 if ( $rOpts->{'assert-tidy'} ) {
862 $rOpts->{'assert-tidy'} = 0;
863 Warn("ignoring --assert-tidy, --format is not 'tidy'\n");
865 if ( $rOpts->{'assert-untidy'} ) {
866 $rOpts->{'assert-untidy'} = 0;
867 Warn("ignoring --assert-untidy, --format is not 'tidy'\n");
871 Perl::Tidy::Formatter::check_options($rOpts);
872 Perl::Tidy::Tokenizer::check_options($rOpts);
873 Perl::Tidy::VerticalAligner::check_options($rOpts);
874 if ( $rOpts->{'format'} eq 'html' ) {
875 Perl::Tidy::HtmlWriter->check_options($rOpts);
878 # make the pattern of file extensions that we shouldn't touch
879 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
880 if ($output_extension) {
881 my $ext = quotemeta($output_extension);
882 $forbidden_file_extensions .= "|$ext";
884 if ( $in_place_modify && $backup_extension ) {
885 my $ext = quotemeta($backup_extension);
886 $forbidden_file_extensions .= "|$ext";
888 $forbidden_file_extensions .= ')$';
890 # Create a diagnostics object if requested;
891 # This is only useful for code development
892 my $diagnostics_object = undef;
893 if ( $rOpts->{'DIAGNOSTICS'} ) {
894 $diagnostics_object = Perl::Tidy::Diagnostics->new();
897 # no filenames should be given if input is from an array
898 if ($source_stream) {
901 "You may not specify any filenames when a source array is given\n"
905 # we'll stuff the source array into ARGV
906 unshift( @ARGV, $source_stream );
908 # No special treatment for source stream which is a filename.
909 # This will enable checks for binary files and other bad stuff.
910 $source_stream = undef unless ref($source_stream);
913 # use stdin by default if no source array and no args
915 unshift( @ARGV, '-' ) unless @ARGV;
918 # Flag for loading module Unicode::GCString for evaluating text width:
919 # undef = ok to use but not yet loaded
920 # 0 = do not use; failed to load or not wanted
921 # 1 = successfully loaded and ok to use
922 # The module is not actually loaded unless/until it is needed
923 my $loaded_unicode_gcstring;
924 if ( !$rOpts->{'use-unicode-gcstring'} ) {
925 $loaded_unicode_gcstring = 0;
928 #---------------------------------------------------------------
930 # main loop to process all files in argument list
931 #---------------------------------------------------------------
932 my $formatter = undef;
933 my $tokenizer = undef;
935 # Remove duplicate filenames. Otherwise, for example if the user entered
936 # perltidy -b myfile.pl myfile.pl
937 # the backup version of the original would be lost.
940 @ARGV = grep { !$seen{$_}++ } @ARGV;
943 # If requested, process in order of increasing file size
944 # This can significantly reduce perl's virtual memory usage during testing.
945 if ( @ARGV > 1 && $rOpts->{'file-size-order'} ) {
948 sort { $a->[1] <=> $b->[1] }
949 map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
952 my $number_of_files = @ARGV;
953 while ( my $input_file = shift @ARGV ) {
958 #---------------------------------------------------------------
959 # prepare this input stream
960 #---------------------------------------------------------------
961 if ($source_stream) {
962 $fileroot = "perltidy";
963 $display_name = "<source_stream>";
965 # If the source is from an array or string, then .LOG output
966 # is only possible if a logfile stream is specified. This prevents
967 # unexpected perltidy.LOG files.
968 if ( !defined($logfile_stream) ) {
969 $logfile_stream = Perl::Tidy::DevNull->new();
971 # Likewise for .TEE and .DEBUG output
973 if ( !defined($teefile_stream) ) {
974 $teefile_stream = Perl::Tidy::DevNull->new();
976 if ( !defined($debugfile_stream) ) {
977 $debugfile_stream = Perl::Tidy::DevNull->new();
980 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
981 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
982 $display_name = "<stdin>";
983 $in_place_modify = 0;
986 $fileroot = $input_file;
987 $display_name = $input_file;
988 unless ( -e $input_file ) {
990 # file doesn't exist - check for a file glob
991 if ( $input_file =~ /([\?\*\[\{])/ ) {
993 # Windows shell may not remove quotes, so do it
994 my $input_file = $input_file;
995 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
996 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
997 my $pattern = fileglob_to_re($input_file);
999 if ( opendir( $dh, './' ) ) {
1001 grep { /$pattern/ && !-d } readdir($dh);
1002 ##grep { /$pattern/ && !-d $_ } readdir($dh);
1005 unshift @ARGV, @files;
1010 Warn("skipping file: '$input_file': no matches found\n");
1014 unless ( -f $input_file ) {
1015 Warn("skipping file: $input_file: not a regular file\n");
1019 # As a safety precaution, skip zero length files.
1020 # If for example a source file got clobbered somehow,
1021 # the old .tdy or .bak files might still exist so we
1022 # shouldn't overwrite them with zero length files.
1023 unless ( -s $input_file ) {
1024 Warn("skipping file: $input_file: Zero size\n");
1028 # And avoid formatting extremely large files. Since perltidy reads
1029 # files into memory, trying to process an extremely large file
1030 # could cause system problems.
1031 my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 );
1032 if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) {
1033 $size_in_mb = sprintf( "%0.1f", $size_in_mb );
1035 "skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n"
1040 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
1042 "skipping file: $input_file: Non-text (override with -f)\n"
1047 # we should have a valid filename now
1048 $fileroot = $input_file;
1049 @input_file_stat = stat($input_file);
1051 if ( $OSNAME eq 'VMS' ) {
1052 ( $fileroot, $dot ) = check_vms_filename($fileroot);
1055 # add option to change path here
1056 if ( defined( $rOpts->{'output-path'} ) ) {
1058 my ( $base, $old_path ) = fileparse($fileroot);
1059 my $new_path = $rOpts->{'output-path'};
1060 unless ( -d $new_path ) {
1061 unless ( mkdir $new_path, 0777 ) {
1062 Die("unable to create directory $new_path: $ERRNO\n");
1065 my $path = $new_path;
1066 $fileroot = catfile( $path, $base );
1067 unless ($fileroot) {
1069 ------------------------------------------------------------------------
1070 Problem combining $new_path and $base to make a filename; check -opath
1071 ------------------------------------------------------------------------
1077 # Skip files with same extension as the output files because
1078 # this can lead to a messy situation with files like
1079 # script.tdy.tdy.tdy ... or worse problems ... when you
1080 # rerun perltidy over and over with wildcard input.
1083 && ( $input_file =~ /$forbidden_file_extensions/
1084 || $input_file eq 'DIAGNOSTICS' )
1087 Warn("skipping file: $input_file: wrong extension\n");
1091 # the 'source_object' supplies a method to read the input file
1092 my $source_object = Perl::Tidy::LineSource->new(
1093 input_file => $input_file,
1095 rpending_logfile_message => $rpending_logfile_message,
1097 next unless ($source_object);
1099 my $max_iterations = $rOpts->{'iterations'};
1100 my $do_convergence_test = $max_iterations > 1;
1101 my $convergence_log_message;
1103 my $digest_input = 0;
1105 my $buf = EMPTY_STRING;
1106 while ( my $line = $source_object->get_line() ) {
1110 my $remove_terminal_newline =
1111 !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
1113 # Decode the input stream if necessary or requested
1114 my $encoding_in = EMPTY_STRING;
1115 my $rOpts_character_encoding = $rOpts->{'character-encoding'};
1116 my $encoding_log_message;
1117 my $decoded_input_as = EMPTY_STRING;
1118 $rstatus->{'char_mode_source'} = 0;
1120 # Case 1: If Perl is already in a character-oriented mode for this
1121 # string rather than a byte-oriented mode. Normally, this happens if
1122 # the caller has decoded a utf8 string before calling perltidy. But it
1123 # could also happen if the user has done some unusual manipulations of
1124 # the source. In any case, we will not attempt to decode it because
1125 # that could result in an output string in a different mode.
1126 if ( is_char_mode($buf) ) {
1127 $encoding_in = "utf8";
1128 $rstatus->{'char_mode_source'} = 1;
1131 # Case 2. No input stream encoding requested. This is appropriate
1132 # for single-byte encodings like ascii, latin-1, etc
1133 elsif ( !$rOpts_character_encoding
1134 || $rOpts_character_encoding eq 'none' )
1140 # Case 3. guess input stream encoding if requested
1141 elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
1143 # The guessing strategy is simple: use Encode::Guess to guess
1144 # an encoding. If and only if the guess is utf8, try decoding and
1145 # use it if successful. Otherwise, we proceed assuming the
1146 # characters are encoded as single bytes (same as if 'none' had
1147 # been specified as the encoding).
1149 # In testing I have found that including additional guess 'suspect'
1150 # encodings sometimes works but can sometimes lead to disaster by
1151 # using an incorrect decoding. The user can always specify a
1152 # specific input encoding.
1155 my $decoder = guess_encoding( $buf_in, 'utf8' );
1156 if ( ref($decoder) ) {
1157 $encoding_in = $decoder->name;
1158 if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
1159 $encoding_in = EMPTY_STRING;
1161 $encoding_log_message .= <<EOM;
1162 Guessed encoding '$encoding_in' is not utf8; no encoding will be used
1167 eval { $buf = $decoder->decode($buf_in); };
1170 $encoding_log_message .= <<EOM;
1171 Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
1174 # Note that a guess failed, but keep going
1175 # This warning can eventually be removed
1177 "file: $input_file: bad guess to decode source as $encoding_in\n"
1179 $encoding_in = EMPTY_STRING;
1183 $encoding_log_message .= <<EOM;
1184 Guessed encoding '$encoding_in' successfully decoded
1186 $decoded_input_as = $encoding_in;
1191 $encoding_log_message .= <<EOM;
1192 Does not look like utf8 encoded text so processing as raw bytes
1197 # Case 4. Decode with a specific encoding
1199 $encoding_in = $rOpts_character_encoding;
1201 $buf = Encode::decode( $encoding_in, $buf,
1202 Encode::FB_CROAK | Encode::LEAVE_SRC );
1206 # Quit if we cannot decode by the requested encoding;
1207 # Something is not right.
1209 "skipping file: $display_name: Unable to decode source as $encoding_in\n"
1214 $encoding_log_message .= <<EOM;
1215 Specified encoding '$encoding_in' successfully decoded
1217 $decoded_input_as = $encoding_in;
1221 # Set the encoding to be used for all further i/o: If we have
1222 # decoded the data with any format, then we must continue to
1223 # read and write it as encoded data, and we will normalize these
1224 # operations with utf8. If we have not decoded the data, then
1225 # we must not treat it as encoded data.
1226 my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
1228 $rstatus->{'input_name'} = $display_name;
1229 $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
1230 $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
1231 $rstatus->{'input_decoded_as'} = $decoded_input_as;
1233 # Define the function to determine the display width of character
1235 my $length_function = sub { return length( $_[0] ) };
1236 if ($is_encoded_data) {
1238 # Delete any Byte Order Mark (BOM), which can cause trouble
1239 $buf =~ s/^\x{FEFF}//;
1241 # Try to load Unicode::GCString for defining text display width, if
1242 # requested, when the first encoded file is encountered
1243 if ( !defined($loaded_unicode_gcstring) ) {
1244 eval { require Unicode::GCString };
1245 $loaded_unicode_gcstring = !$EVAL_ERROR;
1246 if ( $EVAL_ERROR && $rOpts->{'use-unicode-gcstring'} ) {
1248 ----------------------
1249 Unable to load Unicode::GCString: $EVAL_ERROR
1250 Processing continues but some vertical alignment may be poor
1251 To prevent this warning message, you can either:
1252 - install module Unicode::GCString, or
1253 - remove '--use-unicode-gcstring' or '-gcs' from your perltidyrc or command line
1254 ----------------------
1258 if ($loaded_unicode_gcstring) {
1259 $length_function = sub {
1260 return Unicode::GCString->new( $_[0] )->columns;
1262 $encoding_log_message .= <<EOM;
1263 Using 'Unicode::GCString' to measure horizontal character widths
1265 $rstatus->{'gcs_used'} = 1;
1269 # MD5 sum of input file is evaluated before any prefilter
1270 my $saved_input_buf;
1271 if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
1272 $digest_input = $md5_hex->($buf);
1273 $saved_input_buf = $buf;
1276 # Prefilters and postfilters: The prefilter is a code reference
1277 # that will be applied to the source before tidying, and the
1278 # postfilter is a code reference to the result before outputting.
1280 $buf = $prefilter->($buf) if $prefilter;
1282 # starting MD5 sum for convergence test is evaluated after any prefilter
1283 if ($do_convergence_test) {
1284 my $digest = $md5_hex->($buf);
1285 $saw_md5{$digest} = 0;
1288 $source_object = Perl::Tidy::LineSource->new(
1289 input_file => \$buf,
1291 rpending_logfile_message => $rpending_logfile_message,
1294 # register this file name with the Diagnostics package
1295 $diagnostics_object->set_input_file($input_file)
1296 if $diagnostics_object;
1298 #---------------------------------------------------------------
1299 # prepare the output stream
1300 #---------------------------------------------------------------
1301 my $output_file = undef;
1302 my $output_name = EMPTY_STRING;
1303 my $actual_output_extension;
1305 if ( $rOpts->{'outfile'} ) {
1307 if ( $number_of_files <= 1 ) {
1309 if ( $rOpts->{'standard-output'} ) {
1310 my $msg = "You may not use -o and -st together";
1311 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1314 elsif ($destination_stream) {
1316 "You may not specify a destination array and -o together\n"
1319 elsif ( defined( $rOpts->{'output-path'} ) ) {
1320 Die("You may not specify -o and -opath together\n");
1322 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
1323 Die("You may not specify -o and -oext together\n");
1325 $output_file = $rOpts->{outfile};
1326 $output_name = $output_file;
1328 # make sure user gives a file name after -o
1329 if ( $output_file =~ /^-/ ) {
1330 Die("You must specify a valid filename after -o\n");
1333 # do not overwrite input file with -o
1334 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
1335 Die("Use 'perltidy -b $input_file' to modify in-place\n");
1339 Die("You may not use -o with more than one input file\n");
1342 elsif ( $rOpts->{'standard-output'} ) {
1343 if ($destination_stream) {
1345 "You may not specify a destination array and -st together\n";
1346 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1350 $output_name = "<stdout>";
1352 if ( $number_of_files <= 1 ) {
1355 Die("You may not use -st with more than one input file\n");
1358 elsif ($destination_stream) {
1360 $output_file = $destination_stream;
1361 $output_name = "<destination_stream>";
1363 elsif ($source_stream) { # source but no destination goes to stdout
1365 $output_name = "<stdout>";
1367 elsif ( $input_file eq '-' ) {
1369 $output_name = "<stdout>";
1372 if ($in_place_modify) {
1373 $output_file = IO::File->new_tmpfile()
1374 or Die("cannot open temp file for -b option: $ERRNO\n");
1375 $output_name = $display_name;
1378 $actual_output_extension = $output_extension;
1379 $output_file = $fileroot . $output_extension;
1380 $output_name = $output_file;
1384 $rstatus->{'file_count'} += 1;
1385 $rstatus->{'output_name'} = $output_name;
1386 $rstatus->{'iteration_count'} = 0;
1387 $rstatus->{'converged'} = 0;
1390 my $tee_file = $fileroot . $dot . "TEE";
1391 if ($teefile_stream) { $tee_file = $teefile_stream }
1392 if ( $rOpts->{'tee-pod'}
1393 || $rOpts->{'tee-block-comments'}
1394 || $rOpts->{'tee-side-comments'} )
1396 ( $fh_tee, my $tee_filename ) =
1397 Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
1399 Warn("couldn't open TEE file $tee_file: $ERRNO\n");
1403 my $line_separator = $rOpts->{'output-line-ending'};
1404 if ( $rOpts->{'preserve-line-endings'} ) {
1405 $line_separator = find_input_line_ending($input_file);
1408 $line_separator = "\n" unless defined($line_separator);
1410 # the 'sink_object' knows how to write the output file
1411 my ( $sink_object, $postfilter_buffer );
1414 || $remove_terminal_newline
1415 || $rOpts->{'assert-tidy'}
1416 || $rOpts->{'assert-untidy'};
1418 # Postpone final output to a destination SCALAR or ARRAY ref to allow
1419 # possible encoding at the end of processing.
1420 my $destination_buffer;
1421 my $use_destination_buffer;
1422 my $encode_destination_buffer;
1423 my $ref_destination_stream = ref($destination_stream);
1424 if ( $ref_destination_stream && !$user_formatter ) {
1425 $use_destination_buffer = 1;
1426 $output_file = \$destination_buffer;
1428 # Strings and arrays use special encoding rules
1429 if ( $ref_destination_stream eq 'SCALAR'
1430 || $ref_destination_stream eq 'ARRAY' )
1432 $encode_destination_buffer =
1433 $rOpts->{'encode-output-strings'} && $decoded_input_as;
1436 # An object with a print method will use file encoding rules
1437 elsif ( $ref_destination_stream->can('print') ) {
1438 $encode_destination_buffer = $is_encoded_data;
1442 ------------------------------------------------------------------------
1443 No 'print' method is defined for object of class '$ref_destination_stream'
1444 Please check your call to Perl::Tidy::perltidy. Trace follows.
1445 ------------------------------------------------------------------------
1450 $sink_object = Perl::Tidy::LineSink->new(
1451 output_file => $use_buffer ? \$postfilter_buffer : $output_file,
1452 line_separator => $line_separator,
1454 rpending_logfile_message => $rpending_logfile_message,
1455 is_encoded_data => $is_encoded_data,
1458 #---------------------------------------------------------------
1459 # initialize the error logger for this file
1460 #---------------------------------------------------------------
1461 my $warning_file = $fileroot . $dot . "ERR";
1462 if ($errorfile_stream) { $warning_file = $errorfile_stream }
1463 my $log_file = $fileroot . $dot . "LOG";
1464 if ($logfile_stream) { $log_file = $logfile_stream }
1466 my $logger_object = Perl::Tidy::Logger->new(
1468 log_file => $log_file,
1469 warning_file => $warning_file,
1470 fh_stderr => $fh_stderr,
1471 display_name => $display_name,
1472 is_encoded_data => $is_encoded_data,
1474 write_logfile_header(
1475 $rOpts, $logger_object, $config_file,
1476 $rraw_options, $Windows_type, $readable_options,
1478 $logger_object->write_logfile_entry($encoding_log_message)
1479 if $encoding_log_message;
1481 if ( ${$rpending_logfile_message} ) {
1482 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
1484 if ( ${$rpending_complaint} ) {
1485 $logger_object->complain( ${$rpending_complaint} );
1488 #---------------------------------------------------------------
1489 # initialize the debug object, if any
1490 #---------------------------------------------------------------
1491 my $debugger_object = undef;
1492 if ( $rOpts->{DEBUG} ) {
1493 my $debug_file = $fileroot . $dot . "DEBUG";
1494 if ($debugfile_stream) { $debug_file = $debugfile_stream }
1496 Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data );
1499 #---------------------------------------------------------------
1500 # loop over iterations for one source stream
1501 #---------------------------------------------------------------
1503 # save objects to allow redirecting output during iterations
1504 my $sink_object_final = $sink_object;
1505 my $debugger_object_final = $debugger_object;
1506 my $logger_object_final = $logger_object;
1507 my $fh_tee_final = $fh_tee;
1508 my $iteration_of_formatter_convergence;
1510 foreach my $iter ( 1 .. $max_iterations ) {
1512 $rstatus->{'iteration_count'} += 1;
1514 # send output stream to temp buffers until last iteration
1516 if ( $iter < $max_iterations ) {
1517 $sink_object = Perl::Tidy::LineSink->new(
1518 output_file => \$sink_buffer,
1519 line_separator => $line_separator,
1521 rpending_logfile_message => $rpending_logfile_message,
1522 is_encoded_data => $is_encoded_data,
1526 $sink_object = $sink_object_final;
1529 # Save logger, debugger and tee output only on pass 1 because:
1530 # (1) line number references must be to the starting
1531 # source, not an intermediate result, and
1532 # (2) we need to know if there are errors so we can stop the
1533 # iterations early if necessary.
1534 # (3) the tee option only works on first pass if comments are also
1538 $debugger_object = undef;
1539 $logger_object = undef;
1543 #------------------------------------------------------------
1544 # create a formatter for this file : html writer or
1546 #------------------------------------------------------------
1548 # we have to delete any old formatter because, for safety,
1549 # the formatter will check to see that there is only one.
1552 if ($user_formatter) {
1553 $formatter = $user_formatter;
1555 elsif ( $rOpts->{'format'} eq 'html' ) {
1556 $formatter = Perl::Tidy::HtmlWriter->new(
1557 input_file => $fileroot,
1558 html_file => $output_file,
1559 extension => $actual_output_extension,
1560 html_toc_extension => $html_toc_extension,
1561 html_src_extension => $html_src_extension,
1564 elsif ( $rOpts->{'format'} eq 'tidy' ) {
1565 $formatter = Perl::Tidy::Formatter->new(
1566 logger_object => $logger_object,
1567 diagnostics_object => $diagnostics_object,
1568 sink_object => $sink_object,
1569 length_function => $length_function,
1570 is_encoded_data => $is_encoded_data,
1575 Die("I don't know how to do -format=$rOpts->{'format'}\n");
1578 unless ($formatter) {
1579 Die("Unable to continue with $rOpts->{'format'} formatting\n");
1582 #---------------------------------------------------------------
1583 # create the tokenizer for this file
1584 #---------------------------------------------------------------
1585 $tokenizer = undef; # must destroy old tokenizer
1586 $tokenizer = Perl::Tidy::Tokenizer->new(
1587 source_object => $source_object,
1588 logger_object => $logger_object,
1589 debugger_object => $debugger_object,
1590 diagnostics_object => $diagnostics_object,
1591 tabsize => $tabsize,
1594 starting_level => $rOpts->{'starting-indentation-level'},
1595 indent_columns => $rOpts->{'indent-columns'},
1596 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
1597 look_for_autoloader => $rOpts->{'look-for-autoloader'},
1598 look_for_selfloader => $rOpts->{'look-for-selfloader'},
1599 trim_qw => $rOpts->{'trim-qw'},
1600 extended_syntax => $rOpts->{'extended-syntax'},
1602 continuation_indentation =>
1603 $rOpts->{'continuation-indentation'},
1604 outdent_labels => $rOpts->{'outdent-labels'},
1607 #---------------------------------------------------------------
1609 #---------------------------------------------------------------
1610 process_this_file( $tokenizer, $formatter );
1612 #---------------------------------------------------------------
1613 # close the input source and report errors
1614 #---------------------------------------------------------------
1615 $source_object->close_input_file();
1617 # see if the formatter is converged
1618 if ( $max_iterations > 1
1619 && !defined($iteration_of_formatter_convergence)
1620 && $formatter->can('get_convergence_check') )
1622 if ( $formatter->get_convergence_check() ) {
1623 $iteration_of_formatter_convergence = $iter;
1624 $rstatus->{'converged'} = 1;
1628 # line source for next iteration (if any) comes from the current
1629 # temporary output buffer
1630 if ( $iter < $max_iterations ) {
1632 $sink_object->close_output_file();
1633 $source_object = Perl::Tidy::LineSource->new(
1634 input_file => \$sink_buffer,
1636 rpending_logfile_message => $rpending_logfile_message,
1639 # stop iterations if errors or converged
1640 my $stop_now = $tokenizer->report_tokenization_errors();
1641 $stop_now ||= $tokenizer->get_unexpected_error_count();
1642 my $stopping_on_error = $stop_now;
1644 $convergence_log_message = <<EOM;
1645 Stopping iterations because of severe errors.
1648 elsif ($do_convergence_test) {
1650 # stop if the formatter has converged
1651 $stop_now ||= defined($iteration_of_formatter_convergence);
1653 my $digest = $md5_hex->($sink_buffer);
1654 if ( !defined( $saw_md5{$digest} ) ) {
1655 $saw_md5{$digest} = $iter;
1659 # Deja vu, stop iterating
1661 my $iterm = $iter - 1;
1662 if ( $saw_md5{$digest} != $iterm ) {
1664 # Blinking (oscillating) between two or more stable
1665 # end states. This is unlikely to occur with normal
1666 # parameters, but it can occur in stress testing
1667 # with extreme parameter values, such as very short
1668 # maximum line lengths. We want to catch and fix
1669 # them when they happen.
1670 $rstatus->{'blinking'} = 1;
1671 $convergence_log_message = <<EOM;
1672 BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
1674 $stopping_on_error ||= $convergence_log_message;
1676 print STDERR $convergence_log_message;
1678 $diagnostics_object->write_diagnostics(
1679 $convergence_log_message)
1680 if $diagnostics_object;
1682 # Uncomment to search for blinking states
1683 # Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" );
1687 $convergence_log_message = <<EOM;
1688 Converged. Output for iteration $iter same as for iter $iterm.
1690 $diagnostics_object->write_diagnostics(
1691 $convergence_log_message)
1692 if $diagnostics_object && $iterm > 2;
1693 $rstatus->{'converged'} = 1;
1696 } ## end if ($do_convergence_test)
1702 if ( defined($iteration_of_formatter_convergence) ) {
1704 # This message cannot appear unless the formatter
1705 # convergence test above is temporarily skipped for
1707 if ( $iteration_of_formatter_convergence <
1711 "STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n";
1714 elsif ( !$stopping_on_error ) {
1716 "STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n";
1720 # we are stopping the iterations early;
1721 # copy the output stream to its final destination
1722 $sink_object = $sink_object_final;
1723 while ( my $line = $source_object->get_line() ) {
1724 $sink_object->write_line($line);
1726 $source_object->close_input_file();
1729 } ## end if ( $iter < $max_iterations)
1730 } ## end loop over iterations for one source file
1732 # restore objects which have been temporarily undefined
1733 # for second and higher iterations
1734 $debugger_object = $debugger_object_final;
1735 $logger_object = $logger_object_final;
1736 $fh_tee = $fh_tee_final;
1738 $logger_object->write_logfile_entry($convergence_log_message)
1739 if $convergence_log_message;
1741 #---------------------------------------------------------------
1742 # Perform any postfilter operation
1743 #---------------------------------------------------------------
1745 $sink_object->close_output_file();
1746 $sink_object = Perl::Tidy::LineSink->new(
1747 output_file => $output_file,
1748 line_separator => $line_separator,
1750 rpending_logfile_message => $rpending_logfile_message,
1751 is_encoded_data => $is_encoded_data,
1756 ? $postfilter->($postfilter_buffer)
1757 : $postfilter_buffer;
1759 # Check if file changed if requested, but only after any postfilter
1760 if ( $rOpts->{'assert-tidy'} ) {
1761 my $digest_output = $md5_hex->($buf_post);
1762 if ( $digest_output ne $digest_input ) {
1764 compare_string_buffers( $saved_input_buf, $buf_post,
1766 $logger_object->warning(<<EOM);
1767 assertion failure: '--assert-tidy' is set but output differs from input
1769 $logger_object->interrupt_logfile();
1770 $logger_object->warning( $diff_msg . "\n" );
1771 $logger_object->resume_logfile();
1772 ## $Warn_count ||= 1; # logger warning does this now
1775 if ( $rOpts->{'assert-untidy'} ) {
1776 my $digest_output = $md5_hex->($buf_post);
1777 if ( $digest_output eq $digest_input ) {
1778 $logger_object->warning(
1779 "assertion failure: '--assert-untidy' is set but output equals input\n"
1781 ## $Warn_count ||= 1; # logger warning does this now
1785 $source_object = Perl::Tidy::LineSource->new(
1786 input_file => \$buf_post,
1788 rpending_logfile_message => $rpending_logfile_message,
1791 # Copy the filtered buffer to the final destination
1792 if ( !$remove_terminal_newline ) {
1793 while ( my $line = $source_object->get_line() ) {
1794 $sink_object->write_line($line);
1799 # Copy the filtered buffer but remove the newline char from the
1802 while ( my $next_line = $source_object->get_line() ) {
1803 $sink_object->write_line($line) if ($line);
1807 $sink_object->set_line_separator(undef);
1809 $sink_object->write_line($line);
1813 $source_object->close_input_file();
1816 #------------------------------------------------------------------
1817 # For string output, store the result to the destination, encoding
1818 # if requested. This is a fix for issue git #83 (tidyall issue)
1819 #------------------------------------------------------------------
1820 if ($use_destination_buffer) {
1822 # At this point, all necessary encoding has been done except for
1823 # output to a string or array ref. We use the -eos flag to decide
1824 # if we should encode.
1826 # -neos, DEFAULT: perltidy does not return encoded string output.
1827 # This is a result of the code evolution but not very convenient for
1828 # most applications. It would be hard to change without breaking
1831 # -eos flag set: If perltidy decodes a string, regardless of
1832 # source, it encodes before returning.
1833 $rstatus->{'output_encoded_as'} = EMPTY_STRING;
1835 if ($encode_destination_buffer) {
1839 Encode::encode( "UTF-8", $destination_buffer,
1840 Encode::FB_CROAK | Encode::LEAVE_SRC );
1845 "Error attempting to encode output string ref; encoding not done\n"
1849 $destination_buffer = $encoded_buffer;
1850 $rstatus->{'output_encoded_as'} = 'UTF-8';
1854 # Send data for SCALAR, ARRAY & OBJ refs to its final destination
1855 if ( ref($destination_stream) eq 'SCALAR' ) {
1856 ${$destination_stream} = $destination_buffer;
1858 elsif ($destination_buffer) {
1859 my @lines = split /^/, $destination_buffer;
1860 if ( ref($destination_stream) eq 'ARRAY' ) {
1861 @{$destination_stream} = @lines;
1864 # destination stream must be an object with print method
1866 foreach my $line (@lines) {
1867 $destination_stream->print($line);
1869 if ( $ref_destination_stream->can('close') ) {
1870 $destination_stream->close();
1876 # Empty destination buffer not going to a string ... could
1877 # happen for example if user deleted all pod or comments
1882 # output went to a file ...
1883 if ($is_encoded_data) {
1884 $rstatus->{'output_encoded_as'} = 'UTF-8';
1888 # Save names of the input and output files
1889 my $ifname = $input_file;
1890 my $ofname = $output_file;
1892 #---------------------------------------------------------------
1893 # handle the -b option (backup and modify in-place)
1894 #---------------------------------------------------------------
1895 if ($in_place_modify) {
1896 unless ( -f $input_file ) {
1898 # oh, oh, no real file to backup ..
1899 # shouldn't happen because of numerous preliminary checks
1901 "problem with -b backing up input file '$input_file': not a file\n"
1904 my $backup_name = $input_file . $backup_extension;
1905 if ( -f $backup_name ) {
1906 unlink($backup_name)
1908 "unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
1912 # backup the input file
1913 # we use copy for symlinks, move for regular files
1914 if ( -l $input_file ) {
1915 File::Copy::copy( $input_file, $backup_name )
1916 or Die("File::Copy failed trying to backup source: $ERRNO");
1919 rename( $input_file, $backup_name )
1921 "problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
1924 $ifname = $backup_name;
1926 # copy the output to the original input file
1927 # NOTE: it would be nice to just close $output_file and use
1928 # File::Copy::copy here, but in this case $output_file is the
1929 # handle of an open nameless temporary file so we would lose
1930 # everything if we closed it.
1931 seek( $output_file, 0, 0 )
1933 Die("unable to rewind a temporary file for -b option: $ERRNO\n");
1935 my ( $fout, $iname ) =
1936 Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
1939 "problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
1944 while ( $line = $output_file->getline() ) {
1945 $fout->print($line);
1948 $output_file = $input_file;
1949 $ofname = $input_file;
1952 #---------------------------------------------------------------
1953 # clean up and report errors
1954 #---------------------------------------------------------------
1955 $sink_object->close_output_file() if $sink_object;
1956 $debugger_object->close_debug_file() if $debugger_object;
1958 # set output file permissions
1959 if ( $output_file && -f $output_file && !-l $output_file ) {
1960 if (@input_file_stat) {
1962 # Set file ownership and permissions
1963 if ( $rOpts->{'format'} eq 'tidy' ) {
1964 my ( $mode_i, $uid_i, $gid_i ) =
1965 @input_file_stat[ 2, 4, 5 ];
1966 my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
1967 my $input_file_permissions = $mode_i & oct(7777);
1968 my $output_file_permissions = $input_file_permissions;
1970 #rt128477: avoid inconsistent owner/group and suid/sgid
1971 if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
1973 # try to change owner and group to match input file if
1974 # in -b mode. Note: chown returns number of files
1975 # successfully changed.
1976 if ( $in_place_modify
1977 && chown( $uid_i, $gid_i, $output_file ) )
1979 # owner/group successfully changed
1983 # owner or group differ: do not copy suid and sgid
1984 $output_file_permissions = $mode_i & oct(777);
1985 if ( $input_file_permissions !=
1986 $output_file_permissions )
1989 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
1995 # Make the output file for rw unless we are in -b mode.
1996 # Explanation: perltidy does not unlink existing output
1997 # files before writing to them, for safety. If a
1998 # designated output file exists and is not writable,
1999 # perltidy will halt. This can prevent a data loss if a
2000 # user accidentally enters "perltidy infile -o
2001 # important_ro_file", or "perltidy infile -st
2002 # >important_ro_file". But it also means that perltidy can
2003 # get locked out of rerunning unless it marks its own
2004 # output files writable. The alternative, of always
2005 # unlinking the designated output file, is less safe and
2006 # not always possible, except in -b mode, where there is an
2007 # assumption that a previous backup can be unlinked even if
2009 if ( !$in_place_modify ) {
2010 $output_file_permissions |= oct(600);
2013 if ( !chmod( $output_file_permissions, $output_file ) ) {
2015 # couldn't change file permissions
2016 my $operm = sprintf "%04o", $output_file_permissions;
2018 "Unable to set permissions for output file '$output_file' to $operm\n"
2023 # else use default permissions for html and any other format
2027 #---------------------------------------------------------------
2028 # remove the original file for in-place modify as follows:
2029 # $delete_backup=0 never
2030 # $delete_backup=1 only if no errors
2031 # $delete_backup>1 always : NOT ALLOWED, too risky, see above
2032 #---------------------------------------------------------------
2033 if ( $in_place_modify
2036 && ( $delete_backup > 1 || !$logger_object->get_warning_count() ) )
2039 # As an added safety precaution, do not delete the source file
2040 # if its size has dropped from positive to zero, since this
2041 # could indicate a disaster of some kind, including a hardware
2042 # failure. Actually, this could happen if you had a file of
2043 # all comments (or pod) and deleted everything with -dac (-dap)
2045 if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
2047 "output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
2053 "unable to remove previous '$ifname' for -b option; check permissions: $ERRNO\n"
2058 $logger_object->finish($formatter)
2060 } ## end of main loop to process all files
2062 # Fix for RT #130297: return a true value if anything was written to the
2063 # standard error output, even non-fatal warning messages, otherwise return
2066 # These exit codes are returned:
2067 # 0 = perltidy ran to completion with no errors
2068 # 1 = perltidy could not run to completion due to errors
2069 # 2 = perltidy ran to completion with error messages
2071 # Note that if perltidy is run with multiple files, any single file with
2072 # errors or warnings will write a line like
2073 # '## Please see file testing.t.ERR'
2074 # to standard output for each file with errors, so the flag will be true,
2075 # even if only some of the multiple files may have had errors.
2078 my $ret = $Warn_count ? 2 : 0;
2079 return wantarray ? ( $ret, $rstatus ) : $ret;
2082 return wantarray ? ( 1, $rstatus ) : 1;
2084 } ## end sub perltidy
2085 } ## end of closure for sub perltidy
2089 # Given two strings, return
2090 # $diff_marker = a string with carat (^) symbols indicating differences
2091 # $pos1 = character position of first difference; pos1=-1 if no difference
2093 # Form exclusive or of the strings, which has null characters where strings
2094 # have same common characters so non-null characters indicate character
2096 my ( $s1, $s2 ) = @_;
2097 my $diff_marker = EMPTY_STRING;
2100 if ( defined($s1) && defined($s2) ) {
2102 my $mask = $s1 ^ $s2;
2104 while ( $mask =~ /[^\0]/g ) {
2106 my $pos_last = $pos;
2107 $pos = $LAST_MATCH_START[0];
2108 if ( $count == 1 ) { $pos1 = $pos; }
2109 $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
2111 # we could continue to mark all differences, but there is no point
2115 return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
2116 } ## end sub line_diff
2118 sub compare_string_buffers {
2120 # Compare input and output string buffers and return a brief text
2121 # description of the first difference.
2122 my ( $bufi, $bufo, $is_encoded_data ) = @_;
2124 my $leni = length($bufi);
2125 my $leno = defined($bufo) ? length($bufo) : 0;
2127 "Input file length is $leni chars\nOutput file length is $leno chars\n";
2128 return $msg unless $leni && $leno;
2130 my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
2131 my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
2132 return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
2133 my ( $linei, $lineo );
2134 my ( $counti, $counto ) = ( 0, 0 );
2135 my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
2136 my $truncate = sub {
2137 my ( $str, $lenmax ) = @_;
2138 if ( length($str) > $lenmax ) {
2139 $str = substr( $str, 0, $lenmax ) . "...";
2145 $last_nonblank_line = $linei;
2146 $last_nonblank_count = $counti;
2148 $linei = $fhi->getline();
2149 $lineo = $fho->getline();
2151 # compare chomp'ed lines
2152 if ( defined($linei) ) { $counti++; chomp $linei }
2153 if ( defined($lineo) ) { $counto++; chomp $lineo }
2155 # see if one or both ended before a difference
2156 last unless ( defined($linei) && defined($lineo) );
2158 next if ( $linei eq $lineo );
2161 my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
2162 my $reason = "Files first differ at character $pos1 of line $counti";
2164 my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
2165 if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
2166 if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
2167 if ( $leading_ws_i ne $leading_ws_o ) {
2168 $reason .= "; leading whitespace differs";
2169 if ( $leading_ws_i =~ /\t/ ) {
2170 $reason .= "; input has tab char";
2174 my ( $trailing_ws_i, $trailing_ws_o ) =
2175 ( EMPTY_STRING, EMPTY_STRING );
2176 if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
2177 if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
2178 if ( $trailing_ws_i ne $trailing_ws_o ) {
2179 $reason .= "; trailing whitespace differs";
2182 $msg .= $reason . "\n";
2184 # limit string display length
2186 my $drop = $pos1 - 40;
2187 $linei = "..." . substr( $linei, $drop );
2188 $lineo = "..." . substr( $lineo, $drop );
2189 $line_diff = SPACE x 3 . substr( $line_diff, $drop );
2191 $linei = $truncate->( $linei, 72 );
2192 $lineo = $truncate->( $lineo, 72 );
2193 $last_nonblank_line = $truncate->( $last_nonblank_line, 72 );
2195 if ($last_nonblank_line) {
2196 my $countm = $counti - 1;
2198 $last_nonblank_count:$last_nonblank_line
2201 $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
2210 # no line differences found, but one file may have fewer lines
2211 if ( $counti > $counto ) {
2213 Files initially match file but output file has fewer lines
2216 elsif ( $counti < $counto ) {
2218 Files initially match file but input file has fewer lines
2223 Text in lines of file match but checksums differ. Perhaps line endings differ.
2227 } ## end sub compare_string_buffers
2229 sub get_stream_as_named_file {
2231 # Return the name of a file containing a stream of data, creating
2232 # a temporary file if necessary.
2234 # $stream - the name of a file or stream
2236 # $fname = name of file if possible, or undef
2237 # $if_tmpfile = true if temp file, undef if not temp file
2239 # NOTE: This routine was previously needed for passing actual files to Perl
2240 # for a syntax check. It is not currently used.
2245 if ( ref($stream) ) {
2246 my ( $fh_stream, $fh_name ) =
2247 Perl::Tidy::streamhandle( $stream, 'r' );
2249 my ( $fout, $tmpnam ) = File::Temp::tempfile();
2254 while ( my $line = $fh_stream->getline() ) {
2255 $fout->print($line);
2259 $fh_stream->close();
2262 elsif ( $stream ne '-' && -f $stream ) {
2266 return ( $fname, $is_tmpfile );
2267 } ## end sub get_stream_as_named_file
2269 sub fileglob_to_re {
2271 # modified (corrected) from version in find2perl
2273 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
2274 $x =~ s#\*#.*#g; # '*' -> '.*'
2275 $x =~ s#\?#.#g; # '?' -> '.'
2276 return "^$x\\z"; # match whole word
2279 sub make_extension {
2281 # Make a file extension, including any leading '.' if necessary
2282 # The '.' may actually be an '_' under VMS
2283 my ( $extension, $default, $dot ) = @_;
2285 # Use the default if none specified
2286 $extension = $default unless ($extension);
2288 # Only extensions with these leading characters get a '.'
2289 # This rule gives the user some freedom
2290 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
2291 $extension = $dot . $extension;
2294 } ## end sub make_extension
2296 sub write_logfile_header {
2298 $rOpts, $logger_object, $config_file,
2299 $rraw_options, $Windows_type, $readable_options
2302 # Note: the punctuation variable '$]' is not in older versions of
2303 # English.pm so leave it as is to avoid failing installation tests.
2304 $logger_object->write_logfile_entry(
2305 "perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n"
2307 if ($Windows_type) {
2308 $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
2310 my $options_string = join( SPACE, @{$rraw_options} );
2313 $logger_object->write_logfile_entry(
2314 "Found Configuration File >>> $config_file \n");
2316 $logger_object->write_logfile_entry(
2317 "Configuration and command line parameters for this run:\n");
2318 $logger_object->write_logfile_entry("$options_string\n");
2320 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
2321 $rOpts->{'logfile'} = 1; # force logfile to be saved
2322 $logger_object->write_logfile_entry(
2323 "Final parameter set for this run\n");
2324 $logger_object->write_logfile_entry(
2325 "------------------------------------\n");
2327 $logger_object->write_logfile_entry($readable_options);
2329 $logger_object->write_logfile_entry(
2330 "------------------------------------\n");
2332 $logger_object->write_logfile_entry(
2333 "To find error messages search for 'WARNING' with your editor\n");
2335 } ## end sub write_logfile_header
2337 sub generate_options {
2339 ######################################################################
2340 # Generate and return references to:
2341 # @option_string - the list of options to be passed to Getopt::Long
2342 # @defaults - the list of default options
2343 # %expansion - a hash showing how all abbreviations are expanded
2344 # %category - a hash giving the general category of each option
2345 # %option_range - a hash giving the valid ranges of certain options
2347 # Note: a few options are not documented in the man page and usage
2348 # message. This is because these are experimental or debug options and
2349 # may or may not be retained in future versions.
2351 # Here are the undocumented flags as far as I know. Any of them
2352 # may disappear at any time. They are mainly for fine-tuning
2355 # fll --> fuzzy-line-length # a trivial parameter which gets
2356 # turned off for the extrude option
2357 # which is mainly for debugging
2358 # scl --> short-concatenation-item-length # helps break at '.'
2359 # recombine # for debugging line breaks
2360 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
2361 ######################################################################
2363 # here is a summary of the Getopt codes:
2364 # <none> does not take an argument
2365 # =s takes a mandatory string
2366 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
2367 # =i takes a mandatory integer
2368 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
2369 # ! does not take an argument and may be negated
2370 # i.e., -foo and -nofoo are allowed
2371 # a double dash signals the end of the options list
2373 #---------------------------------------------------------------
2374 # Define the option string passed to GetOptions.
2375 #---------------------------------------------------------------
2377 my @option_string = ();
2379 my %option_category = ();
2380 my %option_range = ();
2381 my $rexpansion = \%expansion;
2383 # names of categories in manual
2384 # leading integers will allow sorting
2385 my @category_name = (
2387 '1. Basic formatting options',
2388 '2. Code indentation control',
2389 '3. Whitespace control',
2390 '4. Comment controls',
2391 '5. Linebreak controls',
2392 '6. Controlling list formatting',
2393 '7. Retaining or ignoring existing line breaks',
2394 '8. Blank line control',
2395 '9. Other controls',
2397 '11. pod2html options',
2398 '12. Controlling HTML properties',
2402 # These options are parsed directly by perltidy:
2405 # However, they are included in the option set so that they will
2406 # be seen in the options dump.
2408 # These long option names have no abbreviations or are treated specially
2409 @option_string = qw(
2418 my $category = 13; # Debugging
2419 foreach (@option_string) {
2420 my $opt = $_; # must avoid changing the actual flag
2422 $option_category{$opt} = $category_name[$category];
2425 $category = 11; # HTML
2426 $option_category{html} = $category_name[$category];
2428 # routine to install and check options
2429 my $add_option = sub {
2430 my ( $long_name, $short_name, $flag ) = @_;
2431 push @option_string, $long_name . $flag;
2432 $option_category{$long_name} = $category_name[$category];
2434 if ( $expansion{$short_name} ) {
2435 my $existing_name = $expansion{$short_name}[0];
2437 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
2440 $expansion{$short_name} = [$long_name];
2441 if ( $flag eq '!' ) {
2442 my $nshort_name = 'n' . $short_name;
2443 my $nolong_name = 'no' . $long_name;
2444 if ( $expansion{$nshort_name} ) {
2445 my $existing_name = $expansion{$nshort_name}[0];
2447 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
2450 $expansion{$nshort_name} = [$nolong_name];
2456 # Install long option names which have a simple abbreviation.
2457 # Options with code '!' get standard negation ('no' for long names,
2458 # 'n' for abbreviations). Categories follow the manual.
2460 ###########################
2461 $category = 0; # I/O_Control
2462 ###########################
2463 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
2464 $add_option->( 'backup-file-extension', 'bext', '=s' );
2465 $add_option->( 'character-encoding', 'enc', '=s' );
2466 $add_option->( 'force-read-binary', 'f', '!' );
2467 $add_option->( 'format', 'fmt', '=s' );
2468 $add_option->( 'iterations', 'it', '=i' );
2469 $add_option->( 'logfile', 'log', '!' );
2470 $add_option->( 'logfile-gap', 'g', ':i' );
2471 $add_option->( 'outfile', 'o', '=s' );
2472 $add_option->( 'output-file-extension', 'oext', '=s' );
2473 $add_option->( 'output-path', 'opath', '=s' );
2474 $add_option->( 'profile', 'pro', '=s' );
2475 $add_option->( 'quiet', 'q', '!' );
2476 $add_option->( 'standard-error-output', 'se', '!' );
2477 $add_option->( 'standard-output', 'st', '!' );
2478 $add_option->( 'use-unicode-gcstring', 'gcs', '!' );
2479 $add_option->( 'warning-output', 'w', '!' );
2480 $add_option->( 'add-terminal-newline', 'atnl', '!' );
2482 # options which are both toggle switches and values moved here
2483 # to hide from tidyview (which does not show category 0 flags):
2484 # -ole moved here from category 1
2485 # -sil moved here from category 2
2486 $add_option->( 'output-line-ending', 'ole', '=s' );
2487 $add_option->( 'starting-indentation-level', 'sil', '=i' );
2489 ########################################
2490 $category = 1; # Basic formatting options
2491 ########################################
2492 $add_option->( 'check-syntax', 'syn', '!' );
2493 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
2494 $add_option->( 'indent-columns', 'i', '=i' );
2495 $add_option->( 'maximum-line-length', 'l', '=i' );
2496 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
2497 $add_option->( 'whitespace-cycle', 'wc', '=i' );
2498 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
2499 $add_option->( 'preserve-line-endings', 'ple', '!' );
2500 $add_option->( 'tabs', 't', '!' );
2501 $add_option->( 'default-tabsize', 'dt', '=i' );
2502 $add_option->( 'extended-syntax', 'xs', '!' );
2503 $add_option->( 'assert-tidy', 'ast', '!' );
2504 $add_option->( 'assert-untidy', 'asu', '!' );
2505 $add_option->( 'encode-output-strings', 'eos', '!' );
2506 $add_option->( 'sub-alias-list', 'sal', '=s' );
2507 $add_option->( 'grep-alias-list', 'gal', '=s' );
2508 $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' );
2510 ########################################
2511 $category = 2; # Code indentation control
2512 ########################################
2513 $add_option->( 'continuation-indentation', 'ci', '=i' );
2514 $add_option->( 'extended-continuation-indentation', 'xci', '!' );
2515 $add_option->( 'line-up-parentheses', 'lp', '!' );
2516 $add_option->( 'extended-line-up-parentheses', 'xlp', '!' );
2517 $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' );
2518 $add_option->( 'line-up-parentheses-inclusion-list', 'lpil', '=s' );
2519 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
2520 $add_option->( 'outdent-keywords', 'okw', '!' );
2521 $add_option->( 'outdent-labels', 'ola', '!' );
2522 $add_option->( 'outdent-long-quotes', 'olq', '!' );
2523 $add_option->( 'indent-closing-brace', 'icb', '!' );
2524 $add_option->( 'closing-token-indentation', 'cti', '=i' );
2525 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
2526 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
2527 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
2528 $add_option->( 'brace-left-and-indent', 'bli', '!' );
2529 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
2530 $add_option->( 'brace-left-and-indent-exclusion-list', 'blixl', '=s' );
2532 ########################################
2533 $category = 3; # Whitespace control
2534 ########################################
2535 $add_option->( 'add-semicolons', 'asc', '!' );
2536 $add_option->( 'add-whitespace', 'aws', '!' );
2537 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
2538 $add_option->( 'brace-tightness', 'bt', '=i' );
2539 $add_option->( 'delete-old-whitespace', 'dws', '!' );
2540 $add_option->( 'delete-semicolons', 'dsm', '!' );
2541 $add_option->( 'function-paren-vertical-alignment', 'fpva', '!' );
2542 $add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' );
2543 $add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' );
2544 $add_option->( 'logical-padding', 'lop', '!' );
2545 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
2546 $add_option->( 'nowant-left-space', 'nwls', '=s' );
2547 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
2548 $add_option->( 'paren-tightness', 'pt', '=i' );
2549 $add_option->( 'space-after-keyword', 'sak', '=s' );
2550 $add_option->( 'space-for-semicolon', 'sfs', '!' );
2551 $add_option->( 'space-function-paren', 'sfp', '!' );
2552 $add_option->( 'space-keyword-paren', 'skp', '!' );
2553 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
2554 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
2555 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
2556 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
2557 $add_option->( 'tight-secret-operators', 'tso', '!' );
2558 $add_option->( 'trim-qw', 'tqw', '!' );
2559 $add_option->( 'trim-pod', 'trp', '!' );
2560 $add_option->( 'want-left-space', 'wls', '=s' );
2561 $add_option->( 'want-right-space', 'wrs', '=s' );
2562 $add_option->( 'space-prototype-paren', 'spp', '=i' );
2563 $add_option->( 'valign-code', 'vc', '!' );
2564 $add_option->( 'valign-block-comments', 'vbc', '!' );
2565 $add_option->( 'valign-side-comments', 'vsc', '!' );
2566 $add_option->( 'valign-exclusion-list', 'vxl', '=s' );
2567 $add_option->( 'valign-inclusion-list', 'vil', '=s' );
2569 ########################################
2570 $category = 4; # Comment controls
2571 ########################################
2572 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
2573 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
2574 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
2575 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
2576 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
2577 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
2578 $add_option->( 'closing-side-comments', 'csc', '!' );
2579 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
2580 $add_option->( 'code-skipping', 'cs', '!' );
2581 $add_option->( 'code-skipping-begin', 'csb', '=s' );
2582 $add_option->( 'code-skipping-end', 'cse', '=s' );
2583 $add_option->( 'format-skipping', 'fs', '!' );
2584 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
2585 $add_option->( 'format-skipping-end', 'fse', '=s' );
2586 $add_option->( 'hanging-side-comments', 'hsc', '!' );
2587 $add_option->( 'indent-block-comments', 'ibc', '!' );
2588 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
2589 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
2590 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
2591 $add_option->( 'non-indenting-braces', 'nib', '!' );
2592 $add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' );
2593 $add_option->( 'outdent-long-comments', 'olc', '!' );
2594 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
2595 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
2596 $add_option->( 'static-block-comments', 'sbc', '!' );
2597 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
2598 $add_option->( 'static-side-comments', 'ssc', '!' );
2599 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
2601 ########################################
2602 $category = 5; # Linebreak controls
2603 ########################################
2604 $add_option->( 'add-newlines', 'anl', '!' );
2605 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
2606 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
2607 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
2608 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
2609 $add_option->( 'cuddled-else', 'ce', '!' );
2610 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
2611 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
2612 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
2613 $add_option->( 'delete-old-newlines', 'dnl', '!' );
2614 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
2615 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
2616 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
2617 $add_option->( 'opening-paren-right', 'opr', '!' );
2618 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
2619 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
2620 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
2621 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
2622 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
2623 $add_option->( 'weld-nested-containers', 'wn', '!' );
2624 $add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' );
2625 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
2626 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
2627 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
2628 $add_option->( 'stack-closing-paren', 'scp', '!' );
2629 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
2630 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
2631 $add_option->( 'stack-opening-paren', 'sop', '!' );
2632 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
2633 $add_option->( 'vertical-tightness', 'vt', '=i' );
2634 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
2635 $add_option->( 'want-break-after', 'wba', '=s' );
2636 $add_option->( 'want-break-before', 'wbb', '=s' );
2637 $add_option->( 'break-after-all-operators', 'baao', '!' );
2638 $add_option->( 'break-before-all-operators', 'bbao', '!' );
2639 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
2640 $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
2641 $add_option->( 'one-line-block-nesting', 'olbn', '=i' );
2642 $add_option->( 'break-before-hash-brace', 'bbhb', '=i' );
2643 $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' );
2644 $add_option->( 'break-before-square-bracket', 'bbsb', '=i' );
2645 $add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' );
2646 $add_option->( 'break-before-paren', 'bbp', '=i' );
2647 $add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' );
2648 $add_option->( 'brace-left-list', 'bll', '=s' );
2649 $add_option->( 'brace-left-exclusion-list', 'blxl', '=s' );
2650 $add_option->( 'break-after-labels', 'bal', '=i' );
2652 # This was an experiment mentioned in git #78, originally named -bopl. I
2653 # expanded it to also open logical blocks, based on git discussion #100,
2654 # and renamed it -bocp. It works, but will remain commented out due to
2655 # apparent lack of interest.
2656 # $add_option->( 'break-open-compact-parens', 'bocp', '=s' );
2658 ########################################
2659 $category = 6; # Controlling list formatting
2660 ########################################
2661 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
2662 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
2663 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
2665 ########################################
2666 $category = 7; # Retaining or ignoring existing line breaks
2667 ########################################
2668 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
2669 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
2670 $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
2671 $add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' );
2672 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
2673 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
2674 $add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' );
2675 $add_option->( 'keep-old-breakpoints-after', 'kba', '=s' );
2676 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
2678 ########################################
2679 $category = 8; # Blank line control
2680 ########################################
2681 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
2682 $add_option->( 'blanks-before-comments', 'bbc', '!' );
2683 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
2684 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
2685 $add_option->( 'long-block-line-count', 'lbl', '=i' );
2686 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
2687 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
2689 $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
2690 $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
2691 $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
2692 $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
2693 $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
2694 $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
2695 $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
2697 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
2698 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
2699 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
2700 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
2702 ########################################
2703 $category = 9; # Other controls
2704 ########################################
2705 $add_option->( 'delete-block-comments', 'dbc', '!' );
2706 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
2707 $add_option->( 'delete-pod', 'dp', '!' );
2708 $add_option->( 'delete-side-comments', 'dsc', '!' );
2709 $add_option->( 'tee-block-comments', 'tbc', '!' );
2710 $add_option->( 'tee-pod', 'tp', '!' );
2711 $add_option->( 'tee-side-comments', 'tsc', '!' );
2712 $add_option->( 'look-for-autoloader', 'lal', '!' );
2713 $add_option->( 'look-for-hash-bang', 'x', '!' );
2714 $add_option->( 'look-for-selfloader', 'lsl', '!' );
2715 $add_option->( 'pass-version-line', 'pvl', '!' );
2717 ########################################
2718 $category = 13; # Debugging
2719 ########################################
2720 $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
2721 $add_option->( 'DEBUG', 'D', '!' );
2722 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
2723 $add_option->( 'dump-defaults', 'ddf', '!' );
2724 $add_option->( 'dump-long-names', 'dln', '!' );
2725 $add_option->( 'dump-options', 'dop', '!' );
2726 $add_option->( 'dump-profile', 'dpro', '!' );
2727 $add_option->( 'dump-short-names', 'dsn', '!' );
2728 $add_option->( 'dump-token-types', 'dtt', '!' );
2729 $add_option->( 'dump-want-left-space', 'dwls', '!' );
2730 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
2731 $add_option->( 'fuzzy-line-length', 'fll', '!' );
2732 $add_option->( 'help', 'h', EMPTY_STRING );
2733 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
2734 $add_option->( 'show-options', 'opt', '!' );
2735 $add_option->( 'timestamp', 'ts', '!' );
2736 $add_option->( 'version', 'v', EMPTY_STRING );
2737 $add_option->( 'memoize', 'mem', '!' );
2738 $add_option->( 'file-size-order', 'fso', '!' );
2739 $add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
2740 $add_option->( 'maximum-level-errors', 'maxle', '=i' );
2741 $add_option->( 'maximum-unexpected-errors', 'maxue', '=i' );
2743 #---------------------------------------------------------------------
2745 # The Perl::Tidy::HtmlWriter will add its own options to the string
2746 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
2748 ########################################
2749 # Set categories 10, 11, 12
2750 ########################################
2751 # Based on their known order
2752 $category = 12; # HTML properties
2753 foreach my $opt (@option_string) {
2754 my $long_name = $opt;
2755 $long_name =~ s/(!|=.*|:.*)$//;
2756 unless ( defined( $option_category{$long_name} ) ) {
2757 if ( $long_name =~ /^html-linked/ ) {
2758 $category = 10; # HTML options
2760 elsif ( $long_name =~ /^pod2html/ ) {
2761 $category = 11; # Pod2html
2763 $option_category{$long_name} = $category_name[$category];
2767 #---------------------------------------------------------------
2768 # Assign valid ranges to certain options
2769 #---------------------------------------------------------------
2770 # In the future, these may be used to make preliminary checks
2771 # hash keys are long names
2772 # If key or value is undefined:
2773 # strings may have any value
2774 # integer ranges are >=0
2775 # If value is defined:
2776 # value is [qw(any valid words)] for strings
2777 # value is [min, max] for integers
2778 # if min is undefined, there is no lower limit
2779 # if max is undefined, there is no upper limit
2780 # Parameters not listed here have defaults
2782 'format' => [ 'tidy', 'html', 'user' ],
2783 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
2784 'space-backslash-quote' => [ 0, 2 ],
2785 'block-brace-tightness' => [ 0, 2 ],
2786 'keyword-paren-inner-tightness' => [ 0, 2 ],
2787 'brace-tightness' => [ 0, 2 ],
2788 'paren-tightness' => [ 0, 2 ],
2789 'square-bracket-tightness' => [ 0, 2 ],
2791 'block-brace-vertical-tightness' => [ 0, 2 ],
2792 'brace-vertical-tightness' => [ 0, 2 ],
2793 'brace-vertical-tightness-closing' => [ 0, 2 ],
2794 'paren-vertical-tightness' => [ 0, 2 ],
2795 'paren-vertical-tightness-closing' => [ 0, 2 ],
2796 'square-bracket-vertical-tightness' => [ 0, 2 ],
2797 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
2798 'vertical-tightness' => [ 0, 2 ],
2799 'vertical-tightness-closing' => [ 0, 2 ],
2801 'closing-brace-indentation' => [ 0, 3 ],
2802 'closing-paren-indentation' => [ 0, 3 ],
2803 'closing-square-bracket-indentation' => [ 0, 3 ],
2804 'closing-token-indentation' => [ 0, 3 ],
2806 'closing-side-comment-else-flag' => [ 0, 2 ],
2807 'comma-arrow-breakpoints' => [ 0, 5 ],
2809 'keyword-group-blanks-before' => [ 0, 2 ],
2810 'keyword-group-blanks-after' => [ 0, 2 ],
2812 'space-prototype-paren' => [ 0, 2 ],
2813 'break-after-labels' => [ 0, 2 ],
2816 # Note: we could actually allow negative ci if someone really wants it:
2817 # $option_range{'continuation-indentation'} = [ undef, undef ];
2819 #---------------------------------------------------------------
2820 # DEFAULTS: Assign default values to the above options here, except
2821 # for 'outfile' and 'help'.
2822 # These settings should approximate the perlstyle(1) suggestions.
2823 #---------------------------------------------------------------
2826 add-terminal-newline
2829 blanks-before-blocks
2830 blanks-before-comments
2831 blank-lines-before-subs=1
2832 blank-lines-before-packages=1
2834 keyword-group-blanks-size=5
2835 keyword-group-blanks-repeat-count=0
2836 keyword-group-blanks-before=1
2837 keyword-group-blanks-after=1
2838 nokeyword-group-blanks-inside
2839 nokeyword-group-blanks-delete
2841 block-brace-tightness=0
2842 block-brace-vertical-tightness=0
2844 brace-vertical-tightness-closing=0
2845 brace-vertical-tightness=0
2846 break-after-labels=0
2847 break-at-old-logical-breakpoints
2848 break-at-old-ternary-breakpoints
2849 break-at-old-attribute-breakpoints
2850 break-at-old-keyword-breakpoints
2851 break-before-hash-brace=0
2852 break-before-hash-brace-and-indent=0
2853 break-before-square-bracket=0
2854 break-before-square-bracket-and-indent=0
2855 break-before-paren=0
2856 break-before-paren-and-indent=0
2857 comma-arrow-breakpoints=5
2859 character-encoding=guess
2860 closing-side-comment-interval=6
2861 closing-side-comment-maximum-text=20
2862 closing-side-comment-else-flag=0
2863 closing-side-comments-balanced
2864 closing-paren-indentation=0
2865 closing-brace-indentation=0
2866 closing-square-bracket-indentation=0
2867 continuation-indentation=2
2868 noextended-continuation-indentation
2869 cuddled-break-option=1
2873 encode-output-strings
2874 function-paren-vertical-alignment
2876 hanging-side-comments
2877 indent-block-comments
2880 keep-old-blank-lines=1
2881 keyword-paren-inner-tightness=1
2883 long-block-line-count=8
2886 maximum-consecutive-blank-lines=1
2887 maximum-fields-per-table=0
2888 maximum-line-length=80
2889 maximum-file-size-mb=10
2890 maximum-level-errors=1
2891 maximum-unexpected-errors=0
2893 minimum-space-to-comment=4
2894 nobrace-left-and-indent
2896 nodelete-old-whitespace
2899 non-indenting-braces
2902 nostatic-side-comments
2905 one-line-block-semicolons=1
2906 one-line-block-nesting=0
2909 outdent-long-comments
2911 paren-vertical-tightness-closing=0
2912 paren-vertical-tightness=0
2914 noweld-nested-containers
2916 nouse-unicode-gcstring
2918 valign-block-comments
2919 valign-side-comments
2920 short-concatenation-item-length=8
2922 space-backslash-quote=1
2923 space-prototype-paren=1
2924 square-bracket-tightness=1
2925 square-bracket-vertical-tightness-closing=0
2926 square-bracket-vertical-tightness=0
2927 static-block-comments
2931 backup-file-extension=bak
2937 html-table-of-contents
2941 push @defaults, "perl-syntax-check-flags=-c -T";
2943 #---------------------------------------------------------------
2944 # Define abbreviations which will be expanded into the above primitives.
2945 # These may be defined recursively.
2946 #---------------------------------------------------------------
2949 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
2950 'fnl' => [qw(freeze-newlines)],
2951 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
2952 'fws' => [qw(freeze-whitespace)],
2953 'freeze-blank-lines' =>
2954 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
2955 'fbl' => [qw(freeze-blank-lines)],
2956 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
2957 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
2958 'nooutdent-long-lines' =>
2959 [qw(nooutdent-long-quotes nooutdent-long-comments)],
2960 'oll' => [qw(outdent-long-lines)],
2961 'noll' => [qw(nooutdent-long-lines)],
2962 'io' => [qw(indent-only)],
2963 'delete-all-comments' =>
2964 [qw(delete-block-comments delete-side-comments delete-pod)],
2965 'nodelete-all-comments' =>
2966 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
2967 'dac' => [qw(delete-all-comments)],
2968 'ndac' => [qw(nodelete-all-comments)],
2969 'gnu' => [qw(gnu-style)],
2970 'pbp' => [qw(perl-best-practices)],
2971 'tee-all-comments' =>
2972 [qw(tee-block-comments tee-side-comments tee-pod)],
2973 'notee-all-comments' =>
2974 [qw(notee-block-comments notee-side-comments notee-pod)],
2975 'tac' => [qw(tee-all-comments)],
2976 'ntac' => [qw(notee-all-comments)],
2977 'html' => [qw(format=html)],
2978 'nhtml' => [qw(format=tidy)],
2979 'tidy' => [qw(format=tidy)],
2981 'brace-left' => [qw(opening-brace-on-new-line)],
2983 # -cb is now a synonym for -ce
2984 'cb' => [qw(cuddled-else)],
2985 'cuddled-blocks' => [qw(cuddled-else)],
2987 'utf8' => [qw(character-encoding=utf8)],
2988 'UTF8' => [qw(character-encoding=utf8)],
2989 'guess' => [qw(character-encoding=guess)],
2991 'swallow-optional-blank-lines' => [qw(kbl=0)],
2992 'noswallow-optional-blank-lines' => [qw(kbl=1)],
2993 'sob' => [qw(kbl=0)],
2994 'nsob' => [qw(kbl=1)],
2996 'break-after-comma-arrows' => [qw(cab=0)],
2997 'nobreak-after-comma-arrows' => [qw(cab=1)],
2998 'baa' => [qw(cab=0)],
2999 'nbaa' => [qw(cab=1)],
3001 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
3002 'bbs' => [qw(blbs=1 blbp=1)],
3003 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
3004 'nbbs' => [qw(blbs=0 blbp=0)],
3006 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
3007 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
3008 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
3009 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
3011 'break-at-old-trinary-breakpoints' => [qw(bot)],
3013 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
3014 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
3015 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
3016 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
3017 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
3019 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
3020 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
3021 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
3022 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
3023 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
3025 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3026 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3027 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3029 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3030 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3031 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3033 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3034 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3035 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3037 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3038 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3039 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3041 'otr' => [qw(opr ohbr osbr)],
3042 'opening-token-right' => [qw(opr ohbr osbr)],
3043 'notr' => [qw(nopr nohbr nosbr)],
3044 'noopening-token-right' => [qw(nopr nohbr nosbr)],
3046 'sot' => [qw(sop sohb sosb)],
3047 'nsot' => [qw(nsop nsohb nsosb)],
3048 'stack-opening-tokens' => [qw(sop sohb sosb)],
3049 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
3051 'sct' => [qw(scp schb scsb)],
3052 'stack-closing-tokens' => [qw(scp schb scsb)],
3053 'nsct' => [qw(nscp nschb nscsb)],
3054 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
3056 'sac' => [qw(sot sct)],
3057 'nsac' => [qw(nsot nsct)],
3058 'stack-all-containers' => [qw(sot sct)],
3059 'nostack-all-containers' => [qw(nsot nsct)],
3061 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3062 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3063 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3064 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3065 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3066 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3068 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
3069 'sobb' => [qw(bbvt=2 bbvtl=*)],
3070 'nostack-opening-block-brace' => [qw(bbvt=0)],
3071 'nsobb' => [qw(bbvt=0)],
3073 'converge' => [qw(it=4)],
3074 'noconverge' => [qw(it=1)],
3075 'conv' => [qw(it=4)],
3076 'nconv' => [qw(it=1)],
3078 'valign' => [qw(vc vsc vbc)],
3079 'novalign' => [qw(nvc nvsc nvbc)],
3081 # NOTE: This is a possible future shortcut. But it will remain
3082 # deactivated until the -lpxl flag is no longer experimental.
3083 # 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ],
3084 # 'lfp' => [qw(line-up-function-parentheses)],
3086 # 'mangle' originally deleted pod and comments, but to keep it
3087 # reversible, it no longer does. But if you really want to
3088 # delete them, just use:
3091 # An interesting use for 'mangle' is to do this:
3092 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
3093 # which will form as many one-line blocks as possible
3097 keep-old-blank-lines=0
3099 delete-old-whitespace
3102 maximum-consecutive-blank-lines=0
3103 maximum-line-length=100000
3107 noblanks-before-blocks
3108 blank-lines-before-subs=0
3109 blank-lines-before-packages=0
3114 # 'extrude' originally deleted pod and comments, but to keep it
3115 # reversible, it no longer does. But if you really want to
3116 # delete them, just use
3119 # An interesting use for 'extrude' is to do this:
3120 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
3121 # which will break up all one-line blocks.
3126 delete-old-whitespace
3129 maximum-consecutive-blank-lines=0
3130 maximum-line-length=1
3133 noblanks-before-blocks
3134 blank-lines-before-subs=0
3135 blank-lines-before-packages=0
3142 # this style tries to follow the GNU Coding Standards (which do
3143 # not really apply to perl but which are followed by some perl
3147 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
3151 # Style suggested in Damian Conway's Perl Best Practices
3152 'perl-best-practices' => [
3153 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
3154 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
3157 # Additional styles can be added here
3160 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
3162 # Uncomment next line to dump all expansions for debugging:
3163 # dump_short_names(\%expansion);
3165 \@option_string, \@defaults, \%expansion,
3166 \%option_category, \%option_range
3169 } ## end sub generate_options
3171 # Memoize process_command_line. Given same @ARGV passed in, return same
3172 # values and same @ARGV back.
3173 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
3174 # up masontidy (https://metacpan.org/module/masontidy)
3176 my %process_command_line_cache;
3178 sub process_command_line {
3182 $perltidyrc_stream, $is_Windows, $Windows_type,
3183 $rpending_complaint, $dump_options_type
3186 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
3188 my $cache_key = join( chr(28), @ARGV );
3189 if ( my $result = $process_command_line_cache{$cache_key} ) {
3190 my ( $argv, @retvals ) = @{$result};
3195 my @retvals = _process_command_line(@q);
3196 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
3197 if $retvals[0]->{'memoize'};
3202 return _process_command_line(@q);
3204 } ## end sub process_command_line
3206 # (note the underscore here)
3207 sub _process_command_line {
3210 $perltidyrc_stream, $is_Windows, $Windows_type,
3211 $rpending_complaint, $dump_options_type
3216 # Save any current Getopt::Long configuration
3217 # and set to Getopt::Long defaults. Use eval to avoid
3218 # breaking old versions of Perl without these routines.
3219 # Previous configuration is reset at the exit of this routine.
3221 eval { $glc = Getopt::Long::Configure() };
3222 unless ($EVAL_ERROR) {
3223 eval { Getopt::Long::ConfigDefaults() };
3225 else { $glc = undef }
3228 $roption_string, $rdefaults, $rexpansion,
3229 $roption_category, $roption_range
3230 ) = generate_options();
3232 #---------------------------------------------------------------
3233 # set the defaults by passing the above list through GetOptions
3234 #---------------------------------------------------------------
3239 # do not load the defaults if we are just dumping perltidyrc
3240 unless ( $dump_options_type eq 'perltidyrc' ) {
3241 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
3243 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
3245 "Programming Bug reported by 'GetOptions': error in setting default options"
3251 my @raw_options = ();
3252 my $config_file = EMPTY_STRING;
3253 my $saw_ignore_profile = 0;
3254 my $saw_dump_profile = 0;
3256 #---------------------------------------------------------------
3257 # Take a first look at the command-line parameters. Do as many
3258 # immediate dumps as possible, which can avoid confusion if the
3259 # perltidyrc file has an error.
3260 #---------------------------------------------------------------
3261 foreach my $i (@ARGV) {
3264 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
3265 $saw_ignore_profile = 1;
3268 # note: this must come before -pro and -profile, below:
3269 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
3270 $saw_dump_profile = 1;
3272 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
3275 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
3280 # resolve <dir>/.../<file>, meaning look upwards from directory
3281 if ( defined($config_file) ) {
3282 if ( my ( $start_dir, $search_file ) =
3283 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3285 $start_dir = '.' if !$start_dir;
3286 $start_dir = Cwd::realpath($start_dir);
3287 if ( my $found_file =
3288 find_file_upwards( $start_dir, $search_file ) )
3290 $config_file = $found_file;
3294 unless ( -e $config_file ) {
3295 Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
3296 $config_file = EMPTY_STRING;
3299 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
3300 Die("usage: -pro=filename or --profile=filename, no spaces\n");
3302 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
3306 elsif ( $i =~ /^-(version|v)$/ ) {
3310 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
3311 dump_defaults( @{$rdefaults} );
3314 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
3315 dump_long_names( @{$roption_string} );
3318 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
3319 dump_short_names($rexpansion);
3322 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
3323 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
3328 if ( $saw_dump_profile && $saw_ignore_profile ) {
3329 Warn("No profile to dump because of -npro\n");
3333 #---------------------------------------------------------------
3334 # read any .perltidyrc configuration file
3335 #---------------------------------------------------------------
3336 unless ($saw_ignore_profile) {
3338 # resolve possible conflict between $perltidyrc_stream passed
3339 # as call parameter to perltidy and -pro=filename on command
3341 if ($perltidyrc_stream) {
3344 Conflict: a perltidyrc configuration file was specified both as this
3345 perltidy call parameter: $perltidyrc_stream
3346 and with this -profile=$config_file.
3347 Using -profile=$config_file.
3351 $config_file = $perltidyrc_stream;
3355 # look for a config file if we don't have one yet
3356 my $rconfig_file_chatter;
3357 ${$rconfig_file_chatter} = EMPTY_STRING;
3359 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
3360 $rpending_complaint )
3361 unless $config_file;
3363 # open any config file
3366 ( $fh_config, $config_file ) =
3367 Perl::Tidy::streamhandle( $config_file, 'r' );
3368 unless ($fh_config) {
3369 ${$rconfig_file_chatter} .=
3370 "# $config_file exists but cannot be opened\n";
3374 if ($saw_dump_profile) {
3375 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
3381 my ( $rconfig_list, $death_message ) =
3382 read_config_file( $fh_config, $config_file, $rexpansion );
3383 Die($death_message) if ($death_message);
3385 # process any .perltidyrc parameters right now so we can
3387 if ( @{$rconfig_list} ) {
3388 local @ARGV = @{$rconfig_list};
3390 expand_command_abbreviations( $rexpansion, \@raw_options,
3393 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
3395 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
3399 # Anything left in this local @ARGV is an error and must be
3400 # invalid bare words from the configuration file. We cannot
3401 # check this earlier because bare words may have been valid
3402 # values for parameters. We had to wait for GetOptions to have
3406 my $str = "\'" . pop(@ARGV) . "\'";
3407 while ( my $param = pop(@ARGV) ) {
3408 if ( length($str) < 70 ) {
3409 $str .= ", '$param'";
3417 There are $count unrecognized values in the configuration file '$config_file':
3419 Use leading dashes for parameters. Use -npro to ignore this file.
3423 # Undo any options which cause premature exit. They are not
3424 # appropriate for a config file, and it could be hard to
3425 # diagnose the cause of the premature exit.
3428 dump-cuddled-block-list
3435 dump-want-left-space
3436 dump-want-right-space
3444 if ( defined( $Opts{$_} ) ) {
3446 Warn("ignoring --$_ in config file: $config_file\n");
3453 #---------------------------------------------------------------
3454 # now process the command line parameters
3455 #---------------------------------------------------------------
3456 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
3458 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
3459 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
3460 Die("Error on command line; for help try 'perltidy -h'\n");
3463 # reset Getopt::Long configuration back to its previous value
3464 eval { Getopt::Long::Configure($glc) } if defined $glc;
3466 return ( \%Opts, $config_file, \@raw_options, $roption_string,
3467 $rexpansion, $roption_category, $roption_range );
3468 } ## end sub _process_command_line
3470 sub make_grep_alias_string {
3473 # Defaults: list operators in List::Util
3474 # Possible future additions: pairfirst pairgrep pairmap
3475 my $default_string = join SPACE, qw(
3485 # make a hash of any excluded words
3486 my %is_excluded_word;
3487 my $exclude_string = $rOpts->{'grep-alias-exclusion-list'};
3488 if ($exclude_string) {
3489 $exclude_string =~ s/,/ /g; # allow commas
3490 $exclude_string =~ s/^\s+//;
3491 $exclude_string =~ s/\s+$//;
3492 my @q = split /\s+/, $exclude_string;
3493 @is_excluded_word{@q} = (1) x scalar(@q);
3496 # The special option -gaxl='*' removes all defaults
3497 if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING }
3499 # combine the defaults and any input list
3500 my $input_string = $rOpts->{'grep-alias-list'};
3501 if ($input_string) { $input_string .= SPACE . $default_string }
3502 else { $input_string = $default_string }
3504 # Now make the final list of unique grep alias words
3505 $input_string =~ s/,/ /g; # allow commas
3506 $input_string =~ s/^\s+//;
3507 $input_string =~ s/\s+$//;
3508 my @word_list = split /\s+/, $input_string;
3509 my @filtered_word_list;
3512 foreach my $word (@word_list) {
3514 if ( $word !~ /^\w[\w\d]*$/ ) {
3516 "unexpected word in --grep-alias-list: '$word' - ignoring\n"
3519 if ( !$seen{$word} && !$is_excluded_word{$word} ) {
3521 push @filtered_word_list, $word;
3525 my $joined_words = join SPACE, @filtered_word_list;
3526 $rOpts->{'grep-alias-list'} = $joined_words;
3528 } ## end sub make_grep_alias_string
3532 my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
3534 #---------------------------------------------------------------
3535 # check and handle any interactions among the basic options..
3536 #---------------------------------------------------------------
3538 # Since perltidy only encodes in utf8, problems can occur if we let it
3539 # decode anything else. See discussions for issue git #83.
3540 my $encoding = $rOpts->{'character-encoding'};
3541 if ( $encoding !~ /^\s*(guess|none|utf8|utf-8)\s*$/i ) {
3543 --character-encoding = '$encoding' is not allowed; the options are: 'none', 'guess', 'utf8'
3547 # Since -vt, -vtc, and -cti are abbreviations, but under
3548 # msdos, an unquoted input parameter like vtc=1 will be
3549 # seen as 2 parameters, vtc and 1, so the abbreviations
3550 # won't be seen. Therefore, we will catch them here if
3553 if ( defined $rOpts->{'vertical-tightness'} ) {
3554 my $vt = $rOpts->{'vertical-tightness'};
3555 $rOpts->{'paren-vertical-tightness'} = $vt;
3556 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
3557 $rOpts->{'brace-vertical-tightness'} = $vt;
3560 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
3561 my $vtc = $rOpts->{'vertical-tightness-closing'};
3562 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
3563 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
3564 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
3567 if ( defined $rOpts->{'closing-token-indentation'} ) {
3568 my $cti = $rOpts->{'closing-token-indentation'};
3569 $rOpts->{'closing-square-bracket-indentation'} = $cti;
3570 $rOpts->{'closing-brace-indentation'} = $cti;
3571 $rOpts->{'closing-paren-indentation'} = $cti;
3574 # Syntax checking is no longer supported due to concerns about executing
3575 # code in BEGIN blocks. The flag is still accepted for backwards
3576 # compatibility but is ignored if set.
3577 $rOpts->{'check-syntax'} = 0;
3579 # check iteration count and quietly fix if necessary:
3580 # - iterations option only applies to code beautification mode
3581 # - the convergence check should stop most runs on iteration 2, and
3582 # virtually all on iteration 3. But we'll allow up to 6.
3583 if ( $rOpts->{'format'} ne 'tidy' ) {
3584 $rOpts->{'iterations'} = 1;
3586 elsif ( defined( $rOpts->{'iterations'} ) ) {
3587 if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
3588 elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
3591 $rOpts->{'iterations'} = 1;
3594 my $check_blank_count = sub {
3595 my ( $key, $abbrev ) = @_;
3596 if ( $rOpts->{$key} ) {
3597 if ( $rOpts->{$key} < 0 ) {
3599 Warn("negative value of $abbrev, setting 0\n");
3601 if ( $rOpts->{$key} > 100 ) {
3602 Warn("unreasonably large value of $abbrev, reducing\n");
3603 $rOpts->{$key} = 100;
3609 # check for reasonable number of blank lines and fix to avoid problems
3610 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
3611 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
3612 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
3613 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
3615 # setting a non-negative logfile gap causes logfile to be saved
3616 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
3617 $rOpts->{'logfile'} = 1;
3620 # set short-cut flag when only indentation is to be done.
3621 # Note that the user may or may not have already set the
3623 if ( !$rOpts->{'add-whitespace'}
3624 && !$rOpts->{'delete-old-whitespace'}
3625 && !$rOpts->{'add-newlines'}
3626 && !$rOpts->{'delete-old-newlines'} )
3628 $rOpts->{'indent-only'} = 1;
3631 # -isbc implies -ibc
3632 if ( $rOpts->{'indent-spaced-block-comments'} ) {
3633 $rOpts->{'indent-block-comments'} = 1;
3636 # -bar cannot be used with -bl or -bli; arbitrarily keep -bar
3637 if ( $rOpts->{'opening-brace-always-on-right'} ) {
3639 if ( $rOpts->{'opening-brace-on-new-line'} ) {
3641 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
3642 'opening-brace-on-new-line' (-bl). Ignoring -bl.
3644 $rOpts->{'opening-brace-on-new-line'} = 0;
3646 if ( $rOpts->{'brace-left-and-indent'} ) {
3648 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
3649 '--brace-left-and-indent' (-bli). Ignoring -bli.
3651 $rOpts->{'brace-left-and-indent'} = 0;
3655 # it simplifies things if -bl is 0 rather than undefined
3656 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
3657 $rOpts->{'opening-brace-on-new-line'} = 0;
3660 if ( $rOpts->{'entab-leading-whitespace'} ) {
3661 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
3662 Warn("-et=n must use a positive integer; ignoring -et\n");
3663 $rOpts->{'entab-leading-whitespace'} = undef;
3666 # entab leading whitespace has priority over the older 'tabs' option
3667 if ( $rOpts->{'tabs'} ) {
3669 # The following warning could be added but would annoy a lot of
3670 # users who have a perltidyrc with both -t and -et=n. So instead
3671 # there is a note in the manual that -et overrides -t.
3672 ##Warn("-tabs and -et=n conflict; ignoring -tabs\n");
3673 $rOpts->{'tabs'} = 0;
3677 # set a default tabsize to be used in guessing the starting indentation
3678 # level if and only if this run does not use tabs and the old code does
3680 if ( $rOpts->{'default-tabsize'} ) {
3681 if ( $rOpts->{'default-tabsize'} < 0 ) {
3682 Warn("negative value of -dt, setting 0\n");
3683 $rOpts->{'default-tabsize'} = 0;
3685 if ( $rOpts->{'default-tabsize'} > 20 ) {
3686 Warn("unreasonably large value of -dt, reducing\n");
3687 $rOpts->{'default-tabsize'} = 20;
3691 $rOpts->{'default-tabsize'} = 8;
3694 # Check and clean up any sub-alias-list
3695 if ( $rOpts->{'sub-alias-list'} ) {
3696 my $sub_alias_string = $rOpts->{'sub-alias-list'};
3697 $sub_alias_string =~ s/,/ /g; # allow commas
3698 $sub_alias_string =~ s/^\s+//;
3699 $sub_alias_string =~ s/\s+$//;
3700 my @sub_alias_list = split /\s+/, $sub_alias_string;
3701 my @filtered_word_list = ('sub');
3704 # include 'sub' for later convenience
3706 foreach my $word (@sub_alias_list) {
3708 if ( $word !~ /^\w[\w\d]*$/ ) {
3709 Warn("unexpected sub alias '$word' - ignoring\n");
3711 if ( !$seen{$word} ) {
3713 push @filtered_word_list, $word;
3717 $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list;
3720 make_grep_alias_string($rOpts);
3722 # Turn on fuzzy-line-length unless this is an extrude run, as determined
3723 # by the -i and -ci settings. Otherwise blinkers can form (case b935)
3724 if ( !$rOpts->{'fuzzy-line-length'} ) {
3725 if ( $rOpts->{'maximum-line-length'} != 1
3726 || $rOpts->{'continuation-indentation'} != 0 )
3728 $rOpts->{'fuzzy-line-length'} = 1;
3732 # The freeze-whitespace option is currently a derived option which has its
3734 $rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'}
3735 && !$rOpts->{'delete-old-whitespace'};
3737 # Turn off certain options if whitespace is frozen
3738 # Note: vertical alignment will be automatically shut off
3739 if ( $rOpts->{'freeze-whitespace'} ) {
3740 $rOpts->{'logical-padding'} = 0;
3743 # Define $tabsize, the number of spaces per tab for use in
3744 # guessing the indentation of source lines with leading tabs.
3745 # Assume same as for this run if tabs are used , otherwise assume
3746 # a default value, typically 8
3748 $rOpts->{'entab-leading-whitespace'}
3749 ? $rOpts->{'entab-leading-whitespace'}
3750 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
3751 : $rOpts->{'default-tabsize'};
3753 } ## end sub check_options
3755 sub find_file_upwards {
3756 my ( $search_dir, $search_file ) = @_;
3758 $search_dir =~ s{/+$}{};
3759 $search_file =~ s{^/+}{};
3762 my $try_path = "$search_dir/$search_file";
3763 if ( -f $try_path ) {
3766 elsif ( $search_dir eq '/' ) {
3770 $search_dir = dirname($search_dir);
3774 # This return is for Perl-Critic.
3775 # We shouldn't get out of the while loop without a return
3777 } ## end sub find_file_upwards
3779 sub expand_command_abbreviations {
3781 # go through @ARGV and expand any abbreviations
3783 my ( $rexpansion, $rraw_options, $config_file ) = @_;
3785 # set a pass limit to prevent an infinite loop;
3786 # 10 should be plenty, but it may be increased to allow deeply
3787 # nested expansions.
3788 my $max_passes = 10;
3790 # keep looping until all expansions have been converted into actual
3792 foreach my $pass_count ( 0 .. $max_passes ) {
3794 my $abbrev_count = 0;
3796 # loop over each item in @ARGV..
3797 foreach my $word (@ARGV) {
3799 # convert any leading 'no-' to just 'no'
3800 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
3802 # if it is a dash flag (instead of a file name)..
3803 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
3808 # save the raw input for debug output in case of circular refs
3809 if ( $pass_count == 0 ) {
3810 push( @{$rraw_options}, $word );
3813 # recombine abbreviation and flag, if necessary,
3814 # to allow abbreviations with arguments such as '-vt=1'
3815 if ( $rexpansion->{ $abr . $flags } ) {
3816 $abr = $abr . $flags;
3817 $flags = EMPTY_STRING;
3820 # if we see this dash item in the expansion hash..
3821 if ( $rexpansion->{$abr} ) {
3824 # stuff all of the words that it expands to into the
3825 # new arg list for the next pass
3826 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
3827 next unless $abbrev; # for safety; shouldn't happen
3828 push( @new_argv, '--' . $abbrev . $flags );
3832 # not in expansion hash, must be actual long name
3834 push( @new_argv, $word );
3838 # not a dash item, so just save it for the next pass
3840 push( @new_argv, $word );
3842 } ## end of this pass
3844 # update parameter list @ARGV to the new one
3846 last unless ( $abbrev_count > 0 );
3848 # make sure we are not in an infinite loop
3849 if ( $pass_count == $max_passes ) {
3850 local $LIST_SEPARATOR = ')(';
3852 I'm tired. We seem to be in an infinite loop trying to expand aliases.
3853 Here are the raw options;
3856 my $num = @new_argv;
3859 After $max_passes passes here is ARGV
3865 After $max_passes passes ARGV has $num entries
3871 Please check your configuration file $config_file for circular-references.
3872 To deactivate it, use -npro.
3877 Program bug - circular-references in the %expansion hash, probably due to
3878 a recent program change.
3881 } ## end of check for circular references
3882 } ## end of loop over all passes
3884 } ## end sub expand_command_abbreviations
3886 # Debug routine -- this will dump the expansion hash
3887 sub dump_short_names {
3888 my $rexpansion = shift;
3890 List of short names. This list shows how all abbreviations are
3891 translated into other abbreviations and, eventually, into long names.
3892 New abbreviations may be defined in a .perltidyrc file.
3893 For a list of all long names, use perltidy --dump-long-names (-dln).
3894 --------------------------------------------------------------------------
3896 foreach my $abbrev ( sort keys %{$rexpansion} ) {
3897 my @list = @{ $rexpansion->{$abbrev} };
3898 print STDOUT "$abbrev --> @list\n";
3901 } ## end sub dump_short_names
3903 sub check_vms_filename {
3905 # given a valid filename (the perltidy input file)
3906 # create a modified filename and separator character
3909 # Contributed by Michael Cartmell
3911 my $filename = shift;
3912 my ( $base, $path ) = fileparse($filename);
3914 # remove explicit ; version
3915 $base =~ s/;-?\d*$//
3917 # remove explicit . version ie two dots in filename NB ^ escapes a dot
3918 or $base =~ s/( # begin capture $1
3919 (?:^|[^^])\. # match a dot not preceded by a caret
3920 (?: # followed by nothing
3922 .*[^^] # anything ending in a non caret
3925 \.-?\d*$ # match . version number
3928 # normalize filename, if there are no unescaped dots then append one
3929 $base .= '.' unless $base =~ /(?:^|[^^])\./;
3931 # if we don't already have an extension then we just append the extension
3932 my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_";
3933 return ( $path . $base, $separator );
3934 } ## end sub check_vms_filename
3938 # TODO: are these more standard names?
3939 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
3941 # Returns a string that determines what MS OS we are on.
3942 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
3943 # Returns blank string if not an MS system.
3944 # Original code contributed by: Yves Orton
3945 # We need to know this to decide where to look for config files
3947 my $rpending_complaint = shift;
3948 my $os = EMPTY_STRING;
3949 return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box?
3951 # Systems built from Perl source may not have Win32.pm
3952 # But probably have Win32::GetOSVersion() anyway so the
3953 # following line is not 'required':
3954 # return $os unless eval('require Win32');
3956 # Use the standard API call to determine the version
3957 my ( $undef, $major, $minor, $build, $id );
3958 eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
3961 # NAME ID MAJOR MINOR
3962 # Windows NT 4 2 4 0
3963 # Windows 2000 2 5 0
3965 # Windows Server 2003 2 5 2
3967 return "win32s" unless $id; # If id==0 then its a win32s box.
3968 $os = { # Magic numbers from MSDN
3969 # documentation of GetOSVersion
3976 0 => "2000", # or NT 4, see below
3983 # If $os is undefined, the above code is out of date. Suggested updates
3985 unless ( defined $os ) {
3988 # Deactivated this message 20180322 because it was needlessly
3989 # causing some test scripts to fail. Need help from someone
3990 # with expertise in Windows to decide what is possible with windows.
3991 ${$rpending_complaint} .= <<EOS if (0);
3992 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
3993 We won't be able to look for a system-wide config file.
3997 # Unfortunately the logic used for the various versions isn't so clever..
3998 # so we have to handle an outside case.
3999 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
4000 } ## end sub Win_OS_Type
4004 ( $OSNAME !~ /win32|dos/i )
4005 && ( $OSNAME ne 'VMS' )
4006 && ( $OSNAME ne 'OS2' )
4007 && ( $OSNAME ne 'MacOS' );
4010 sub look_for_Windows {
4012 # determine Windows sub-type and location of
4013 # system-wide configuration files
4014 my $rpending_complaint = shift;
4015 my $is_Windows = ( $OSNAME =~ /win32|dos/i );
4017 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
4018 return ( $is_Windows, $Windows_type );
4019 } ## end sub look_for_Windows
4021 sub find_config_file {
4023 # look for a .perltidyrc configuration file
4024 # For Windows also look for a file named perltidy.ini
4025 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
4026 $rpending_complaint )
4029 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
4031 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
4034 ${$rconfig_file_chatter} .= " $OSNAME\n";
4037 # sub to check file existence and record all tests
4038 my $exists_config_file = sub {
4039 my $config_file = shift;
4040 return 0 unless $config_file;
4041 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
4042 return -f $config_file;
4045 # Sub to search upward for config file
4046 my $resolve_config_file = sub {
4048 # resolve <dir>/.../<file>, meaning look upwards from directory
4049 my $config_file = shift;
4051 if ( my ( $start_dir, $search_file ) =
4052 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
4054 ${$rconfig_file_chatter} .=
4055 "# Searching Upward: $config_file\n";
4056 $start_dir = '.' if !$start_dir;
4057 $start_dir = Cwd::realpath($start_dir);
4058 if ( my $found_file =
4059 find_file_upwards( $start_dir, $search_file ) )
4061 $config_file = $found_file;
4062 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
4066 return $config_file;
4071 # look in current directory first
4072 $config_file = ".perltidyrc";
4073 return $config_file if $exists_config_file->($config_file);
4075 $config_file = "perltidy.ini";
4076 return $config_file if $exists_config_file->($config_file);
4079 # Default environment vars.
4080 my @envs = qw(PERLTIDY HOME);
4082 # Check the NT/2k/XP locations, first a local machine def, then a
4084 push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
4086 # Now go through the environment ...
4087 foreach my $var (@envs) {
4088 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
4089 if ( defined( $ENV{$var} ) ) {
4090 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
4092 # test ENV{ PERLTIDY } as file:
4093 if ( $var eq 'PERLTIDY' ) {
4094 $config_file = "$ENV{$var}";
4095 $config_file = $resolve_config_file->($config_file);
4096 return $config_file if $exists_config_file->($config_file);
4099 # test ENV as directory:
4100 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
4101 $config_file = $resolve_config_file->($config_file);
4102 return $config_file if $exists_config_file->($config_file);
4105 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
4106 $config_file = $resolve_config_file->($config_file);
4107 return $config_file if $exists_config_file->($config_file);
4111 ${$rconfig_file_chatter} .= "\n";
4115 # then look for a system-wide definition
4116 # where to look varies with OS
4119 if ($Windows_type) {
4120 my ( $os, $system, $allusers ) =
4121 Win_Config_Locs( $rpending_complaint, $Windows_type );
4123 # Check All Users directory, if there is one.
4124 # i.e. C:\Documents and Settings\User\perltidy.ini
4127 $config_file = catfile( $allusers, ".perltidyrc" );
4128 return $config_file if $exists_config_file->($config_file);
4130 $config_file = catfile( $allusers, "perltidy.ini" );
4131 return $config_file if $exists_config_file->($config_file);
4134 # Check system directory.
4135 # retain old code in case someone has been able to create
4136 # a file with a leading period.
4137 $config_file = catfile( $system, ".perltidyrc" );
4138 return $config_file if $exists_config_file->($config_file);
4140 $config_file = catfile( $system, "perltidy.ini" );
4141 return $config_file if $exists_config_file->($config_file);
4145 # Place to add customization code for other systems
4146 elsif ( $OSNAME eq 'OS2' ) {
4148 elsif ( $OSNAME eq 'MacOS' ) {
4150 elsif ( $OSNAME eq 'VMS' ) {
4153 # Assume some kind of Unix
4156 $config_file = "/usr/local/etc/perltidyrc";
4157 return $config_file if $exists_config_file->($config_file);
4159 $config_file = "/etc/perltidyrc";
4160 return $config_file if $exists_config_file->($config_file);
4163 # Couldn't find a config file
4165 } ## end sub find_config_file
4167 sub Win_Config_Locs {
4169 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
4170 # or undef if its not a win32 OS. In list context returns OS, System
4171 # Directory, and All Users Directory. All Users will be empty on a
4172 # 9x/Me box. Contributed by: Yves Orton.
4175 # my $rpending_complaint = shift;
4176 # my $os = (@_) ? shift : Win_OS_Type();
4178 my ( $rpending_complaint, $os ) = @_;
4179 if ( !$os ) { $os = Win_OS_Type(); }
4183 my $system = EMPTY_STRING;
4184 my $allusers = EMPTY_STRING;
4186 if ( $os =~ /9[58]|Me/ ) {
4187 $system = "C:/Windows";
4189 elsif ( $os =~ /NT|XP|200?/ ) {
4190 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
4193 ? "C:/WinNT/profiles/All Users/"
4194 : "C:/Documents and Settings/All Users/";
4198 # This currently would only happen on a win32s computer. I don't have
4199 # one to test, so I am unsure how to proceed. Suggestions welcome!
4200 ${$rpending_complaint} .=
4201 "I dont know a sensible place to look for config files on an $os system.\n";
4204 return wantarray ? ( $os, $system, $allusers ) : $os;
4205 } ## end sub Win_Config_Locs
4207 sub dump_config_file {
4208 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
4209 print STDOUT "$$rconfig_file_chatter";
4211 print STDOUT "# Dump of file: '$config_file'\n";
4212 while ( my $line = $fh->getline() ) { print STDOUT $line }
4213 eval { $fh->close() };
4216 print STDOUT "# ...no config file found\n";
4219 } ## end sub dump_config_file
4221 sub read_config_file {
4223 my ( $fh, $config_file, $rexpansion ) = @_;
4224 my @config_list = ();
4226 # file is bad if non-empty $death_message is returned
4227 my $death_message = EMPTY_STRING;
4231 my $opening_brace_line;
4232 while ( my $line = $fh->getline() ) {
4235 ( $line, $death_message ) =
4236 strip_comment( $line, $config_file, $line_no );
4237 last if ($death_message);
4239 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
4244 # Look for complete or partial abbreviation definition of the form
4245 # name { body } or name { or name { body
4246 # See rules in perltidy's perldoc page
4247 # Section: Other Controls - Creating a new abbreviation
4248 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
4249 my $oldname = $name;
4250 ( $name, $body ) = ( $2, $3 );
4252 # Cannot start new abbreviation unless old abbreviation is complete
4253 last if ($opening_brace_line);
4255 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
4257 # handle a new alias definition
4258 if ( $rexpansion->{$name} ) {
4259 local $LIST_SEPARATOR = ')(';
4260 my @names = sort keys %{$rexpansion};
4262 "Here is a list of all installed aliases\n(@names)\n"
4263 . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
4266 $rexpansion->{$name} = [];
4269 # leading opening braces not allowed
4270 elsif ( $line =~ /^{/ ) {
4271 $opening_brace_line = undef;
4273 "Unexpected '{' at line $line_no in config file '$config_file'\n";
4277 # Look for abbreviation closing: body } or }
4278 elsif ( $line =~ /^(.*)?\}$/ ) {
4280 if ($opening_brace_line) {
4281 $opening_brace_line = undef;
4285 "Unexpected '}' at line $line_no in config file '$config_file'\n";
4290 # Now store any parameters
4293 my ( $rbody_parts, $msg ) = parse_args($body);
4295 $death_message = <<EOM;
4296 Error reading file '$config_file' at line number $line_no.
4298 Please fix this line or use -npro to avoid reading this file
4305 # remove leading dashes if this is an alias
4306 foreach ( @{$rbody_parts} ) { s/^\-+//; }
4307 push @{ $rexpansion->{$name} }, @{$rbody_parts};
4310 push( @config_list, @{$rbody_parts} );
4315 if ($opening_brace_line) {
4317 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
4319 eval { $fh->close() };
4320 return ( \@config_list, $death_message );
4321 } ## end sub read_config_file
4325 # Strip any comment from a command line
4326 my ( $instr, $config_file, $line_no ) = @_;
4327 my $msg = EMPTY_STRING;
4329 # check for full-line comment
4330 if ( $instr =~ /^\s*#/ ) {
4331 return ( EMPTY_STRING, $msg );
4334 # nothing to do if no comments
4335 if ( $instr !~ /#/ ) {
4336 return ( $instr, $msg );
4339 # handle case of no quotes
4340 elsif ( $instr !~ /['"]/ ) {
4342 # We now require a space before the # of a side comment
4343 # this allows something like:
4345 # Otherwise, it would have to be quoted:
4347 $instr =~ s/\s+\#.*$//;
4348 return ( $instr, $msg );
4351 # handle comments and quotes
4352 my $outstr = EMPTY_STRING;
4353 my $quote_char = EMPTY_STRING;
4356 # looking for ending quote character
4358 if ( $instr =~ /\G($quote_char)/gc ) {
4359 $quote_char = EMPTY_STRING;
4362 elsif ( $instr =~ /\G(.)/gc ) {
4366 # error..we reached the end without seeing the ending quote char
4369 Error reading file $config_file at line number $line_no.
4370 Did not see ending quote character <$quote_char> in this text:
4372 Please fix this line or use -npro to avoid reading this file
4378 # accumulating characters and looking for start of a quoted string
4380 if ( $instr =~ /\G([\"\'])/gc ) {
4385 # Note: not yet enforcing the space-before-hash rule for side
4386 # comments if the parameter is quoted.
4387 elsif ( $instr =~ /\G#/gc ) {
4390 elsif ( $instr =~ /\G(.)/gc ) {
4398 return ( $outstr, $msg );
4399 } ## end sub strip_comment
4403 # Parse a command string containing multiple string with possible
4404 # quotes, into individual commands. It might look like this, for example:
4406 # -wba=" + - " -some-thing -wbb='. && ||'
4408 # There is no need, at present, to handle escaped quote characters.
4409 # (They are not perltidy tokens, so needn't be in strings).
4412 my @body_parts = ();
4413 my $quote_char = EMPTY_STRING;
4414 my $part = EMPTY_STRING;
4415 my $msg = EMPTY_STRING;
4417 # Check for external call with undefined $body - added to fix
4418 # github issue Perl-Tidy-Sweetened issue #23
4419 if ( !defined($body) ) { $body = EMPTY_STRING }
4423 # looking for ending quote character
4425 if ( $body =~ /\G($quote_char)/gc ) {
4426 $quote_char = EMPTY_STRING;
4428 elsif ( $body =~ /\G(.)/gc ) {
4432 # error..we reached the end without seeing the ending quote char
4434 if ( length($part) ) { push @body_parts, $part; }
4436 Did not see ending quote character <$quote_char> in this text:
4443 # accumulating characters and looking for start of a quoted string
4445 if ( $body =~ /\G([\"\'])/gc ) {
4448 elsif ( $body =~ /\G(\s+)/gc ) {
4449 if ( length($part) ) { push @body_parts, $part; }
4450 $part = EMPTY_STRING;
4452 elsif ( $body =~ /\G(.)/gc ) {
4456 if ( length($part) ) { push @body_parts, $part; }
4461 return ( \@body_parts, $msg );
4462 } ## end sub parse_args
4464 sub dump_long_names {
4468 # Command line long names (passed to GetOptions)
4469 #---------------------------------------------------------------
4470 # here is a summary of the Getopt codes:
4471 # <none> does not take an argument
4472 # =s takes a mandatory string
4473 # :s takes an optional string
4474 # =i takes a mandatory integer
4475 # :i takes an optional integer
4476 # ! does not take an argument and may be negated
4477 # i.e., -foo and -nofoo are allowed
4478 # a double dash signals the end of the options list
4480 #---------------------------------------------------------------
4483 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
4485 } ## end sub dump_long_names
4489 print STDOUT "Default command line options:\n";
4490 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
4494 sub readable_options {
4496 # return options for this run as a string which could be
4497 # put in a perltidyrc file
4498 my ( $rOpts, $roption_string ) = @_;
4500 my $rGetopt_flags = \%Getopt_flags;
4501 my $readable_options = "# Final parameter set for this run.\n";
4502 $readable_options .=
4503 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
4504 foreach my $opt ( @{$roption_string} ) {
4505 my $flag = EMPTY_STRING;
4506 if ( $opt =~ /(.*)(!|=.*)$/ ) {
4510 if ( defined( $rOpts->{$opt} ) ) {
4511 $rGetopt_flags->{$opt} = $flag;
4514 foreach my $key ( sort keys %{$rOpts} ) {
4515 my $flag = $rGetopt_flags->{$key};
4516 my $value = $rOpts->{$key};
4518 my $suffix = EMPTY_STRING;
4520 if ( $flag =~ /^=/ ) {
4521 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
4522 $suffix = "=" . $value;
4524 elsif ( $flag =~ /^!/ ) {
4525 $prefix .= "no" unless ($value);
4530 $readable_options .=
4531 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
4534 $readable_options .= $prefix . $key . $suffix . "\n";
4536 return $readable_options;
4537 } ## end sub readable_options
4540 print STDOUT <<"EOM";
4541 This is perltidy, v$VERSION
4543 Copyright 2000-2022, Steve Hancock
4545 Perltidy is free software and may be copied under the terms of the GNU
4546 General Public License, which is included in the distribution files.
4548 Complete documentation for perltidy can be found using 'man perltidy'
4549 or on the internet at http://perltidy.sourceforge.net.
4552 } ## end sub show_version
4557 This is perltidy version $VERSION, a perl script indenter. Usage:
4559 perltidy [ options ] file1 file2 file3 ...
4560 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
4561 perltidy [ options ] file1 -o outfile
4562 perltidy [ options ] file1 -st >outfile
4563 perltidy [ options ] <infile >outfile
4565 Options have short and long forms. Short forms are shown; see
4566 man pages for long forms. Note: '=s' indicates a required string,
4567 and '=n' indicates a required integer.
4571 -o=file name of the output file (only if single input file)
4572 -oext=s change output extension from 'tdy' to s
4573 -opath=path change path to be 'path' for output files
4574 -b backup original to .bak and modify file in-place
4575 -bext=s change default backup extension from 'bak' to s
4576 -q deactivate error messages (for running under editor)
4577 -w include non-critical warning messages in the .ERR error output
4578 -log save .LOG file, which has useful diagnostics
4579 -f force perltidy to read a binary file
4580 -g like -log but writes more detailed .LOG file, for debugging scripts
4581 -opt write the set of options actually used to a .LOG file
4582 -npro ignore .perltidyrc configuration command file
4583 -pro=file read configuration commands from file instead of .perltidyrc
4584 -st send output to standard output, STDOUT
4585 -se send all error output to standard error output, STDERR
4586 -v display version number to standard output and quit
4589 -i=n use n columns per indentation level (default n=4)
4590 -t tabs: use one tab character per indentation level, not recommended
4591 -nt no tabs: use n spaces per indentation level (default)
4592 -et=n entab leading whitespace n spaces per tab; not recommended
4593 -io "indent only": just do indentation, no other formatting.
4594 -sil=n set starting indentation level to n; use if auto detection fails
4595 -ole=s specify output line ending (s=dos or win, mac, unix)
4596 -ple keep output line endings same as input (input must be filename)
4599 -fws freeze whitespace; this disables all whitespace changes
4600 and disables the following switches:
4601 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
4602 -bbt same as -bt but for code block braces; same as -bt if not given
4603 -bbvt block braces vertically tight; use with -bl or -bli
4604 -bbvtl=s make -bbvt to apply to selected list of block types
4605 -pt=n paren tightness (n=0, 1 or 2)
4606 -sbt=n square bracket tightness (n=0, 1, or 2)
4607 -bvt=n brace vertical tightness,
4608 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
4609 -pvt=n paren vertical tightness (see -bvt for n)
4610 -sbvt=n square bracket vertical tightness (see -bvt for n)
4611 -bvtc=n closing brace vertical tightness:
4612 n=(0=open, 1=sometimes close, 2=always close)
4613 -pvtc=n closing paren vertical tightness, see -bvtc for n.
4614 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
4615 -ci=n sets continuation indentation=n, default is n=2 spaces
4616 -lp line up parentheses, brackets, and non-BLOCK braces
4617 -sfs add space before semicolon in for( ; ; )
4618 -aws allow perltidy to add whitespace (default)
4619 -dws delete all old non-essential whitespace
4620 -icb indent closing brace of a code block
4621 -cti=n closing indentation of paren, square bracket, or non-block brace:
4622 n=0 none, =1 align with opening, =2 one full indentation level
4623 -icp equivalent to -cti=2
4624 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
4625 -wrs=s want space right of tokens in string;
4626 -sts put space before terminal semicolon of a statement
4627 -sak=s put space between keywords given in s and '(';
4628 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
4631 -fnl freeze newlines; this disables all line break changes
4632 and disables the following switches:
4633 -anl add newlines; ok to introduce new line breaks
4634 -bbs add blank line before subs and packages
4635 -bbc add blank line before block comments
4636 -bbb add blank line between major blocks
4637 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
4638 -mbl=n maximum consecutive blank lines to output (default=1)
4639 -ce cuddled else; use this style: '} else {'
4640 -cb cuddled blocks (other than 'if-elsif-else')
4641 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
4642 -dnl delete old newlines (default)
4643 -l=n maximum line length; default n=80
4644 -bl opening brace on new line
4645 -sbl opening sub brace on new line. value of -bl is used if not given.
4646 -bli opening brace on new line and indented
4647 -bar opening brace always on right, even for long clauses
4648 -vt=n vertical tightness (requires -lp); n controls break after opening
4649 token: 0=never 1=no break if next line balanced 2=no break
4650 -vtc=n vertical tightness of closing container; n controls if closing
4651 token starts new line: 0=always 1=not unless list 1=never
4652 -wba=s want break after tokens in string; i.e. wba=': .'
4653 -wbb=s want break before tokens in string
4654 -wn weld nested: combines opening and closing tokens when both are adjacent
4655 -wnxl=s weld nested exclusion list: provides some control over the types of
4656 containers which can be welded
4658 Following Old Breakpoints
4659 -kis keep interior semicolons. Allows multiple statements per line.
4660 -boc break at old comma breaks: turns off all automatic list formatting
4661 -bol break at old logical breakpoints: or, and, ||, && (default)
4662 -bom break at old method call breakpoints: ->
4663 -bok break at old list keyword breakpoints such as map, sort (default)
4664 -bot break at old conditional (ternary ?:) operator breakpoints (default)
4665 -boa break at old attribute breakpoints
4666 -cab=n break at commas after a comma-arrow (=>):
4667 n=0 break at all commas after =>
4668 n=1 stable: break unless this breaks an existing one-line container
4669 n=2 break only if a one-line container cannot be formed
4670 n=3 do not treat commas after => specially at all
4673 -ibc indent block comments (default)
4674 -isbc indent spaced block comments; may indent unless no leading space
4675 -msc=n minimum desired spaces to side comment, default 4
4676 -fpsc=n fix position for side comments; default 0;
4677 -csc add or update closing side comments after closing BLOCK brace
4678 -dcsc delete closing side comments created by a -csc command
4679 -cscp=s change closing side comment prefix to be other than '## end'
4680 -cscl=s change closing side comment to apply to selected list of blocks
4681 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
4682 -csct=n maximum number of columns of appended text, default n=20
4683 -cscw causes warning if old side comment is overwritten with -csc
4685 -sbc use 'static block comments' identified by leading '##' (default)
4686 -sbcp=s change static block comment identifier to be other than '##'
4687 -osbc outdent static block comments
4689 -ssc use 'static side comments' identified by leading '##' (default)
4690 -sscp=s change static side comment identifier to be other than '##'
4692 Delete selected text
4693 -dac delete all comments AND pod
4694 -dbc delete block comments
4695 -dsc delete side comments
4698 Send selected text to a '.TEE' file
4699 -tac tee all comments AND pod
4700 -tbc tee block comments
4701 -tsc tee side comments
4705 -olq outdent long quoted strings (default)
4706 -olc outdent a long block comment line
4707 -ola outdent statement labels
4708 -okw outdent control keywords (redo, next, last, goto, return)
4709 -okwl=s specify alternative keywords for -okw command
4712 -mft=n maximum fields per table; default n=40
4713 -x do not format lines before hash-bang line (i.e., for VMS)
4714 -asc allows perltidy to add a ';' when missing (default)
4715 -dsm allows perltidy to delete an unnecessary ';' (default)
4717 Combinations of other parameters
4718 -gnu attempt to follow GNU Coding Standards as applied to perl
4719 -mangle remove as many newlines as possible (but keep comments and pods)
4720 -extrude insert as many newlines as possible
4722 Dump and die, debugging
4723 -dop dump options used in this run to standard output and quit
4724 -ddf dump default options to standard output and quit
4725 -dsn dump all option short names to standard output and quit
4726 -dln dump option long names to standard output and quit
4727 -dpro dump whatever configuration file is in effect to standard output
4728 -dtt dump all token types to standard output and quit
4731 -html write an html file (see 'man perl2web' for many options)
4732 Note: when -html is used, no indentation or formatting are done.
4733 Hint: try perltidy -html -css=mystyle.css filename.pl
4734 and edit mystyle.css to change the appearance of filename.html.
4735 -nnn gives line numbers
4736 -pre only writes out <pre>..</pre> code section
4737 -toc places a table of contents to subs at the top (default)
4738 -pod passes pod text through pod2html (default)
4739 -frm write html as a frame (3 files)
4740 -text=s extra extension for table of contents if -frm, default='toc'
4741 -sext=s extra extension for file content if -frm, default='src'
4743 A prefix of "n" negates short form toggle switches, and a prefix of "no"
4744 negates the long forms. For example, -nasc means don't add missing
4747 If you are unable to see this entire text, try "perltidy -h | more"
4748 For more detailed information, and additional options, try "man perltidy",
4749 or go to the perltidy home page at http://perltidy.sourceforge.net
4755 sub process_this_file {
4757 my ( $tokenizer, $formatter ) = @_;
4759 while ( my $line = $tokenizer->get_line() ) {
4760 $formatter->write_line($line);
4762 my $severe_error = $tokenizer->report_tokenization_errors();
4764 # user-defined formatters are possible, and may not have a
4765 # sub 'finish_formatting', so we have to check
4766 $formatter->finish_formatting($severe_error)
4767 if $formatter->can('finish_formatting');
4770 } ## end sub process_this_file