2 ###########################################################-
4 # perltidy - a perl script indenter and formatter
6 # Copyright (c) 2000-2019 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 Digest::MD5 qw(md5_hex);
66 use Perl::Tidy::Debugger;
67 use Perl::Tidy::DevNull;
68 use Perl::Tidy::Diagnostics;
69 use Perl::Tidy::FileWriter;
70 use Perl::Tidy::Formatter;
71 use Perl::Tidy::HtmlWriter;
72 use Perl::Tidy::IOScalar;
73 use Perl::Tidy::IOScalarArray;
74 use Perl::Tidy::IndentationItem;
75 use Perl::Tidy::LineSink;
76 use Perl::Tidy::LineSource;
77 use Perl::Tidy::Logger;
78 use Perl::Tidy::Tokenizer;
79 use Perl::Tidy::VerticalAligner;
88 $rOpts_character_encoding
92 @ISA = qw( Exporter );
93 @EXPORT = qw( &perltidy );
100 use File::Temp qw(tempfile);
104 # Release version is the approximate YYMMDD of the release.
105 # Development version is (Last Release).(Development Number)
107 # To make the number continually increasing, the Development Number is a 2
108 # digit number starting at 01 after a release is continually bumped along
109 # at significant points during development. If it ever reaches 99 then the
110 # Release version must be bumped, and it is probably past time for a
113 $VERSION = '20200110';
118 # given filename and mode (r or w), create an object which:
119 # has a 'getline' method if mode='r', and
120 # has a 'print' method if mode='w'.
121 # The objects also need a 'close' method.
123 # How the object is made:
125 # if $filename is: Make object using:
126 # ---------------- -----------------
127 # '-' (STDIN if mode = 'r', STDOUT if mode='w')
129 # ARRAY ref Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
130 # STRING ref Perl::Tidy::IOScalar (formerly IO::Scalar)
132 # (check for 'print' method for 'w' mode)
133 # (check for 'getline' method for 'r' mode)
134 my ( $filename, $mode ) = @_;
136 my $ref = ref($filename);
142 if ( $ref eq 'ARRAY' ) {
143 $New = sub { Perl::Tidy::IOScalarArray->new(@_) };
145 elsif ( $ref eq 'SCALAR' ) {
146 $New = sub { Perl::Tidy::IOScalar->new(@_) };
150 # Accept an object with a getline method for reading. Note:
151 # IO::File is built-in and does not respond to the defined
152 # operator. If this causes trouble, the check can be
153 # skipped and we can just let it crash if there is no
155 if ( $mode =~ /[rR]/ ) {
157 # RT#97159; part 1 of 2: updated to use 'can'
158 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
159 if ( $ref->can('getline') ) {
160 $New = sub { $filename };
163 $New = sub { undef };
165 ------------------------------------------------------------------------
166 No 'getline' method is defined for object of class $ref
167 Please check your call to Perl::Tidy::perltidy. Trace follows.
168 ------------------------------------------------------------------------
173 # Accept an object with a print method for writing.
174 # See note above about IO::File
175 if ( $mode =~ /[wW]/ ) {
177 # RT#97159; part 2 of 2: updated to use 'can'
178 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
179 if ( $ref->can('print') ) {
180 $New = sub { $filename };
183 $New = sub { undef };
185 ------------------------------------------------------------------------
186 No 'print' method is defined for object of class $ref
187 Please check your call to Perl::Tidy::perltidy. Trace follows.
188 ------------------------------------------------------------------------
197 if ( $filename eq '-' ) {
198 $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
201 $New = sub { IO::File->new(@_) };
204 $fh = $New->( $filename, $mode )
205 or Warn("Couldn't open file:$filename in mode:$mode : $!\n");
207 return $fh, ( $ref or $filename );
210 sub find_input_line_ending {
212 # Peek at a file and return first line ending character.
213 # Return undefined value in case of any trouble.
214 my ($input_file) = @_;
217 # silently ignore input from object or stdin
218 if ( ref($input_file) || $input_file eq '-' ) {
223 open( $fh, '<', $input_file ) || return $ending;
227 read( $fh, $buf, 1024 );
229 if ( $buf && $buf =~ /([\012\015]+)/ ) {
233 if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
236 elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
239 elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
253 # concatenate a path and file basename
254 # returns undef in case of error
259 eval { require File::Spec };
260 $missing_file_spec = $@;
263 # use File::Spec if we can
264 unless ($missing_file_spec) {
265 return File::Spec->catfile(@parts);
268 # Perl 5.004 systems may not have File::Spec so we'll make
269 # a simple try. We assume File::Basename is available.
270 # return if not successful.
271 my $name = pop @parts;
272 my $path = join '/', @parts;
273 my $test_file = $path . $name;
274 my ( $test_name, $test_path ) = fileparse($test_file);
275 return $test_file if ( $test_name eq $name );
276 return if ( $^O eq 'VMS' );
278 # this should work at least for Windows and Unix:
279 $test_file = $path . '/' . $name;
280 ( $test_name, $test_path ) = fileparse($test_file);
281 return $test_file if ( $test_name eq $name );
285 # Here is a map of the flow of data from the input source to the output
288 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
289 # input groups output
290 # lines tokens lines of lines lines
293 # The names correspond to the package names responsible for the unit processes.
295 # The overall process is controlled by the "main" package.
297 # LineSource is the stream of input lines
299 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
300 # if necessary. A token is any section of the input line which should be
301 # manipulated as a single entity during formatting. For example, a single
302 # ',' character is a token, and so is an entire side comment. It handles
303 # the complexities of Perl syntax, such as distinguishing between '<<' as
304 # a shift operator and as a here-document, or distinguishing between '/'
305 # as a divide symbol and as a pattern delimiter.
307 # Formatter inserts and deletes whitespace between tokens, and breaks
308 # sequences of tokens at appropriate points as output lines. It bases its
309 # decisions on the default rules as modified by any command-line options.
311 # VerticalAligner collects groups of lines together and tries to line up
312 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
314 # FileWriter simply writes lines to the output stream.
316 # The Logger package, not shown, records significant events and warning
317 # messages. It writes a .LOG file, which may be saved with a
318 # '-log' or a '-g' flag.
326 destination => undef,
333 dump_options => undef,
334 dump_options_type => undef,
335 dump_getopt_flags => undef,
336 dump_options_category => undef,
337 dump_options_range => undef,
338 dump_abbreviations => undef,
343 # don't overwrite callers ARGV
345 local *STDERR = *STDERR;
347 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
349 my @good_keys = sort keys %defaults;
350 @bad_keys = sort @bad_keys;
352 ------------------------------------------------------------------------
353 Unknown perltidy parameter : (@bad_keys)
354 perltidy only understands : (@good_keys)
355 ------------------------------------------------------------------------
360 my $get_hash_ref = sub {
362 my $hash_ref = $input_hash{$key};
363 if ( defined($hash_ref) ) {
364 unless ( ref($hash_ref) eq 'HASH' ) {
365 my $what = ref($hash_ref);
367 $what ? "but is ref to $what" : "but is not a reference";
369 ------------------------------------------------------------------------
370 error in call to perltidy:
371 -$key must be reference to HASH $but_is
372 ------------------------------------------------------------------------
379 %input_hash = ( %defaults, %input_hash );
380 my $argv = $input_hash{'argv'};
381 my $destination_stream = $input_hash{'destination'};
382 my $errorfile_stream = $input_hash{'errorfile'};
383 my $logfile_stream = $input_hash{'logfile'};
384 my $perltidyrc_stream = $input_hash{'perltidyrc'};
385 my $source_stream = $input_hash{'source'};
386 my $stderr_stream = $input_hash{'stderr'};
387 my $user_formatter = $input_hash{'formatter'};
388 my $prefilter = $input_hash{'prefilter'};
389 my $postfilter = $input_hash{'postfilter'};
391 if ($stderr_stream) {
392 ( $fh_stderr, my $stderr_file ) =
393 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
396 ------------------------------------------------------------------------
397 Unable to redirect STDERR to $stderr_stream
398 Please check value of -stderr in call to perltidy
399 ------------------------------------------------------------------------
404 $fh_stderr = *STDERR;
407 sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
411 if ($flag) { goto ERROR_EXIT }
412 else { goto NORMAL_EXIT }
413 croak "unexpectd return to Exit";
420 croak "unexpected return to Die";
426 # Evaluate the MD5 sum for a string
427 # Patch for [rt.cpan.org #88020]
428 # Use utf8::encode since md5_hex() only operates on bytes.
429 # my $digest = md5_hex( utf8::encode($sink_buffer) );
431 # Note added 20180114: the above patch did not work correctly. I'm not
432 # sure why. But switching to the method recommended in the Perl 5
433 # documentation for Encode worked. According to this we can either use
434 # $octets = encode_utf8($string) or equivalently
435 # $octets = encode("utf8",$string)
436 # and then calculate the checksum. So:
437 my $octets = Encode::encode( "utf8", $buf );
438 my $digest = md5_hex($octets);
442 # extract various dump parameters
443 my $dump_options_type = $input_hash{'dump_options_type'};
444 my $dump_options = $get_hash_ref->('dump_options');
445 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
446 my $dump_options_category = $get_hash_ref->('dump_options_category');
447 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
448 my $dump_options_range = $get_hash_ref->('dump_options_range');
450 # validate dump_options_type
451 if ( defined($dump_options) ) {
452 unless ( defined($dump_options_type) ) {
453 $dump_options_type = 'perltidyrc';
455 unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
457 ------------------------------------------------------------------------
458 Please check value of -dump_options_type in call to perltidy;
459 saw: '$dump_options_type'
460 expecting: 'perltidyrc' or 'full'
461 ------------------------------------------------------------------------
467 $dump_options_type = "";
470 if ($user_formatter) {
472 # if the user defines a formatter, there is no output stream,
473 # but we need a null stream to keep coding simple
474 $destination_stream = Perl::Tidy::DevNull->new();
477 # see if ARGV is overridden
478 if ( defined($argv) ) {
480 my $rargv = ref $argv;
481 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
485 if ( $rargv eq 'ARRAY' ) {
490 ------------------------------------------------------------------------
491 Please check value of -argv in call to perltidy;
492 it must be a string or ref to ARRAY but is: $rargv
493 ------------------------------------------------------------------------
500 my ( $rargv, $msg ) = parse_args($argv);
503 Error parsing this string passed to to perltidy with 'argv':
511 my $rpending_complaint;
512 ${$rpending_complaint} = "";
513 my $rpending_logfile_message;
514 ${$rpending_logfile_message} = "";
516 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
518 # VMS file names are restricted to a 40.40 format, so we append _tdy
519 # instead of .tdy, etc. (but see also sub check_vms_filename)
522 if ( $^O eq 'VMS' ) {
528 $dot_pattern = '\.'; # must escape for use in regex
531 #---------------------------------------------------------------
532 # get command line options
533 #---------------------------------------------------------------
534 my ( $rOpts, $config_file, $rraw_options, $roption_string,
535 $rexpansion, $roption_category, $roption_range )
536 = process_command_line(
537 $perltidyrc_stream, $is_Windows, $Windows_type,
538 $rpending_complaint, $dump_options_type,
541 my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
543 ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
545 #---------------------------------------------------------------
546 # Handle requests to dump information
547 #---------------------------------------------------------------
549 # return or exit immediately after all dumps
552 # Getopt parameters and their flags
553 if ( defined($dump_getopt_flags) ) {
555 foreach my $op ( @{$roption_string} ) {
564 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
568 $dump_getopt_flags->{$opt} = $flag;
572 if ( defined($dump_options_category) ) {
574 %{$dump_options_category} = %{$roption_category};
577 if ( defined($dump_options_range) ) {
579 %{$dump_options_range} = %{$roption_range};
582 if ( defined($dump_abbreviations) ) {
584 %{$dump_abbreviations} = %{$rexpansion};
587 if ( defined($dump_options) ) {
589 %{$dump_options} = %{$rOpts};
592 Exit(0) if ($quit_now);
594 # make printable string of options for this run as possible diagnostic
595 my $readable_options = readable_options( $rOpts, $roption_string );
597 # dump from command line
598 if ( $rOpts->{'dump-options'} ) {
599 print STDOUT $readable_options;
603 #---------------------------------------------------------------
604 # check parameters and their interactions
605 #---------------------------------------------------------------
607 check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
609 if ($user_formatter) {
610 $rOpts->{'format'} = 'user';
613 # there must be one entry here for every possible format
614 my %default_file_extension = (
620 $rOpts_character_encoding = $rOpts->{'character-encoding'};
622 # be sure we have a valid output format
623 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
624 my $formats = join ' ',
625 sort map { "'" . $_ . "'" } keys %default_file_extension;
626 my $fmt = $rOpts->{'format'};
627 Die("-format='$fmt' but must be one of: $formats\n");
630 my $output_extension = make_extension( $rOpts->{'output-file-extension'},
631 $default_file_extension{ $rOpts->{'format'} }, $dot );
633 # If the backup extension contains a / character then the backup should
634 # be deleted when the -b option is used. On older versions of
635 # perltidy this will generate an error message due to an illegal
638 # A backup file will still be generated but will be deleted
639 # at the end. If -bext='/' then this extension will be
640 # the default 'bak'. Otherwise it will be whatever characters
641 # remains after all '/' characters are removed. For example:
642 # -bext extension slashes
646 # '/dev/null' devnull 2 (Currently not allowed)
647 my $bext = $rOpts->{'backup-file-extension'};
648 my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
650 # At present only one forward slash is allowed. In the future multiple
651 # slashes may be allowed to allow for other options
652 if ( $delete_backup > 1 ) {
653 Die("-bext=$bext contains more than one '/'\n");
656 my $backup_extension =
657 make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
659 my $html_toc_extension =
660 make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
662 my $html_src_extension =
663 make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
665 # check for -b option;
666 # silently ignore unless beautify mode
667 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
668 && $rOpts->{'format'} eq 'tidy';
670 # Turn off -b with warnings in case of conflicts with other options.
671 # NOTE: Do this silently, without warnings, if there is a source or
672 # destination stream, or standard output is used. This is because the -b
673 # flag may have been in a .perltidyrc file and warnings break
674 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
675 if ($in_place_modify) {
676 if ( $rOpts->{'standard-output'}
677 || $destination_stream
678 || ref $source_stream
679 || $rOpts->{'outfile'}
680 || defined( $rOpts->{'output-path'} ) )
682 $in_place_modify = 0;
686 Perl::Tidy::Formatter::check_options($rOpts);
687 Perl::Tidy::Tokenizer::check_options($rOpts);
688 if ( $rOpts->{'format'} eq 'html' ) {
689 Perl::Tidy::HtmlWriter->check_options($rOpts);
692 # make the pattern of file extensions that we shouldn't touch
693 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
694 if ($output_extension) {
695 my $ext = quotemeta($output_extension);
696 $forbidden_file_extensions .= "|$ext";
698 if ( $in_place_modify && $backup_extension ) {
699 my $ext = quotemeta($backup_extension);
700 $forbidden_file_extensions .= "|$ext";
702 $forbidden_file_extensions .= ')$';
704 # Create a diagnostics object if requested;
705 # This is only useful for code development
706 my $diagnostics_object = undef;
707 if ( $rOpts->{'DIAGNOSTICS'} ) {
708 $diagnostics_object = Perl::Tidy::Diagnostics->new();
711 # no filenames should be given if input is from an array
712 if ($source_stream) {
715 "You may not specify any filenames when a source array is given\n"
719 # we'll stuff the source array into ARGV
720 unshift( @ARGV, $source_stream );
722 # No special treatment for source stream which is a filename.
723 # This will enable checks for binary files and other bad stuff.
724 $source_stream = undef unless ref($source_stream);
727 # use stdin by default if no source array and no args
729 unshift( @ARGV, '-' ) unless @ARGV;
732 #---------------------------------------------------------------
734 # main loop to process all files in argument list
735 #---------------------------------------------------------------
736 my $number_of_files = @ARGV;
737 my $formatter = undef;
738 my $tokenizer = undef;
740 # If requested, process in order of increasing file size
741 # This can significantly reduce perl's virtual memory usage during testing.
742 if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) {
745 sort { $a->[1] <=> $b->[1] }
746 map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
749 while ( my $input_file = shift @ARGV ) {
754 #---------------------------------------------------------------
755 # prepare this input stream
756 #---------------------------------------------------------------
757 if ($source_stream) {
758 $fileroot = "perltidy";
759 $display_name = "<source_stream>";
761 # If the source is from an array or string, then .LOG output
762 # is only possible if a logfile stream is specified. This prevents
763 # unexpected perltidy.LOG files.
764 if ( !defined($logfile_stream) ) {
765 $logfile_stream = Perl::Tidy::DevNull->new();
768 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
769 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
770 $display_name = "<stdin>";
771 $in_place_modify = 0;
774 $fileroot = $input_file;
775 $display_name = $input_file;
776 unless ( -e $input_file ) {
778 # file doesn't exist - check for a file glob
779 if ( $input_file =~ /([\?\*\[\{])/ ) {
781 # Windows shell may not remove quotes, so do it
782 my $input_file = $input_file;
783 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
784 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
785 my $pattern = fileglob_to_re($input_file);
787 if ( !$@ && opendir( DIR, './' ) ) {
789 grep { /$pattern/ && !-d $_ } readdir(DIR);
792 unshift @ARGV, @files;
797 Warn("skipping file: '$input_file': no matches found\n");
801 unless ( -f $input_file ) {
802 Warn("skipping file: $input_file: not a regular file\n");
806 # As a safety precaution, skip zero length files.
807 # If for example a source file got clobbered somehow,
808 # the old .tdy or .bak files might still exist so we
809 # shouldn't overwrite them with zero length files.
810 unless ( -s $input_file ) {
811 Warn("skipping file: $input_file: Zero size\n");
815 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
817 "skipping file: $input_file: Non-text (override with -f)\n"
822 # we should have a valid filename now
823 $fileroot = $input_file;
824 @input_file_stat = stat($input_file);
826 if ( $^O eq 'VMS' ) {
827 ( $fileroot, $dot ) = check_vms_filename($fileroot);
830 # add option to change path here
831 if ( defined( $rOpts->{'output-path'} ) ) {
833 my ( $base, $old_path ) = fileparse($fileroot);
834 my $new_path = $rOpts->{'output-path'};
835 unless ( -d $new_path ) {
836 unless ( mkdir $new_path, 0777 ) {
837 Die("unable to create directory $new_path: $!\n");
840 my $path = $new_path;
841 $fileroot = catfile( $path, $base );
844 ------------------------------------------------------------------------
845 Problem combining $new_path and $base to make a filename; check -opath
846 ------------------------------------------------------------------------
852 # Skip files with same extension as the output files because
853 # this can lead to a messy situation with files like
854 # script.tdy.tdy.tdy ... or worse problems ... when you
855 # rerun perltidy over and over with wildcard input.
858 && ( $input_file =~ /$forbidden_file_extensions/o
859 || $input_file eq 'DIAGNOSTICS' )
862 Warn("skipping file: $input_file: wrong extension\n");
866 # the 'source_object' supplies a method to read the input file
868 Perl::Tidy::LineSource->new( $input_file, $rOpts,
869 $rpending_logfile_message );
870 next unless ($source_object);
872 my $max_iterations = $rOpts->{'iterations'};
873 my $do_convergence_test = $max_iterations > 1;
874 my $convergence_log_message;
876 my $digest_input = 0;
878 # Prefilters and postfilters: The prefilter is a code reference
879 # that will be applied to the source before tidying, and the
880 # postfilter is a code reference to the result before outputting.
883 || ( $rOpts_character_encoding
884 && $rOpts_character_encoding eq 'utf8' )
885 || $rOpts->{'assert-tidy'}
886 || $rOpts->{'assert-untidy'}
887 || $do_convergence_test
891 while ( my $line = $source_object->get_line() ) {
895 if ( $rOpts_character_encoding
896 && $rOpts_character_encoding eq 'utf8'
897 && !utf8::is_utf8($buf) )
900 $buf = Encode::decode( 'UTF-8', $buf,
901 Encode::FB_CROAK | Encode::LEAVE_SRC );
905 "skipping file: $input_file: Unable to decode source as UTF-8\n"
911 # MD5 sum of input file is evaluated before any prefilter
912 if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
913 $digest_input = $md5_hex->($buf);
916 $buf = $prefilter->($buf) if $prefilter;
918 # starting MD5 sum for convergence test is evaluated after any prefilter
919 if ($do_convergence_test) {
920 my $digest = $md5_hex->($buf);
921 $saw_md5{$digest} = 1;
924 $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
925 $rpending_logfile_message );
928 # register this file name with the Diagnostics package
929 $diagnostics_object->set_input_file($input_file)
930 if $diagnostics_object;
932 #---------------------------------------------------------------
933 # prepare the output stream
934 #---------------------------------------------------------------
935 my $output_file = undef;
936 my $actual_output_extension;
938 if ( $rOpts->{'outfile'} ) {
940 if ( $number_of_files <= 1 ) {
942 if ( $rOpts->{'standard-output'} ) {
943 my $msg = "You may not use -o and -st together";
944 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
947 elsif ($destination_stream) {
949 "You may not specify a destination array and -o together\n"
952 elsif ( defined( $rOpts->{'output-path'} ) ) {
953 Die("You may not specify -o and -opath together\n");
955 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
956 Die("You may not specify -o and -oext together\n");
958 $output_file = $rOpts->{outfile};
960 # make sure user gives a file name after -o
961 if ( $output_file =~ /^-/ ) {
962 Die("You must specify a valid filename after -o\n");
965 # do not overwrite input file with -o
966 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
967 Die("Use 'perltidy -b $input_file' to modify in-place\n");
971 Die("You may not use -o with more than one input file\n");
974 elsif ( $rOpts->{'standard-output'} ) {
975 if ($destination_stream) {
977 "You may not specify a destination array and -st together\n";
978 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
983 if ( $number_of_files <= 1 ) {
986 Die("You may not use -st with more than one input file\n");
989 elsif ($destination_stream) {
990 $output_file = $destination_stream;
992 elsif ($source_stream) { # source but no destination goes to stdout
995 elsif ( $input_file eq '-' ) {
999 if ($in_place_modify) {
1000 $output_file = IO::File->new_tmpfile()
1001 or Die("cannot open temp file for -b option: $!\n");
1004 $actual_output_extension = $output_extension;
1005 $output_file = $fileroot . $output_extension;
1009 # the 'sink_object' knows how to write the output file
1010 my $tee_file = $fileroot . $dot . "TEE";
1012 my $line_separator = $rOpts->{'output-line-ending'};
1013 if ( $rOpts->{'preserve-line-endings'} ) {
1014 $line_separator = find_input_line_ending($input_file);
1017 # Eventually all I/O may be done with binmode, but for now it is
1018 # only done when a user requests a particular line separator
1019 # through the -ple or -ole flags
1020 my $binmode = defined($line_separator)
1021 || defined($rOpts_character_encoding);
1022 $line_separator = "\n" unless defined($line_separator);
1024 my ( $sink_object, $postfilter_buffer );
1026 || $rOpts->{'assert-tidy'}
1027 || $rOpts->{'assert-untidy'} )
1030 Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
1031 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
1035 Perl::Tidy::LineSink->new( $output_file, $tee_file,
1036 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
1039 #---------------------------------------------------------------
1040 # initialize the error logger for this file
1041 #---------------------------------------------------------------
1042 my $warning_file = $fileroot . $dot . "ERR";
1043 if ($errorfile_stream) { $warning_file = $errorfile_stream }
1044 my $log_file = $fileroot . $dot . "LOG";
1045 if ($logfile_stream) { $log_file = $logfile_stream }
1048 Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
1049 $fh_stderr, $saw_extrude, $display_name );
1050 write_logfile_header(
1051 $rOpts, $logger_object, $config_file,
1052 $rraw_options, $Windows_type, $readable_options,
1054 if ( ${$rpending_logfile_message} ) {
1055 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
1057 if ( ${$rpending_complaint} ) {
1058 $logger_object->complain( ${$rpending_complaint} );
1061 #---------------------------------------------------------------
1062 # initialize the debug object, if any
1063 #---------------------------------------------------------------
1064 my $debugger_object = undef;
1065 if ( $rOpts->{DEBUG} ) {
1067 Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
1070 #---------------------------------------------------------------
1071 # loop over iterations for one source stream
1072 #---------------------------------------------------------------
1074 # save objects to allow redirecting output during iterations
1075 my $sink_object_final = $sink_object;
1076 my $debugger_object_final = $debugger_object;
1077 my $logger_object_final = $logger_object;
1079 foreach my $iter ( 1 .. $max_iterations ) {
1081 # send output stream to temp buffers until last iteration
1083 if ( $iter < $max_iterations ) {
1085 Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
1086 $line_separator, $rOpts, $rpending_logfile_message,
1090 $sink_object = $sink_object_final;
1093 # Save logger, debugger output only on pass 1 because:
1094 # (1) line number references must be to the starting
1095 # source, not an intermediate result, and
1096 # (2) we need to know if there are errors so we can stop the
1097 # iterations early if necessary.
1099 $debugger_object = undef;
1100 $logger_object = undef;
1103 #------------------------------------------------------------
1104 # create a formatter for this file : html writer or
1106 #------------------------------------------------------------
1108 # we have to delete any old formatter because, for safety,
1109 # the formatter will check to see that there is only one.
1112 if ($user_formatter) {
1113 $formatter = $user_formatter;
1115 elsif ( $rOpts->{'format'} eq 'html' ) {
1117 Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
1118 $actual_output_extension, $html_toc_extension,
1119 $html_src_extension );
1121 elsif ( $rOpts->{'format'} eq 'tidy' ) {
1122 $formatter = Perl::Tidy::Formatter->new(
1123 logger_object => $logger_object,
1124 diagnostics_object => $diagnostics_object,
1125 sink_object => $sink_object,
1129 Die("I don't know how to do -format=$rOpts->{'format'}\n");
1132 unless ($formatter) {
1133 Die("Unable to continue with $rOpts->{'format'} formatting\n");
1136 #---------------------------------------------------------------
1137 # create the tokenizer for this file
1138 #---------------------------------------------------------------
1139 $tokenizer = undef; # must destroy old tokenizer
1140 $tokenizer = Perl::Tidy::Tokenizer->new(
1141 source_object => $source_object,
1142 logger_object => $logger_object,
1143 debugger_object => $debugger_object,
1144 diagnostics_object => $diagnostics_object,
1145 tabsize => $tabsize,
1147 starting_level => $rOpts->{'starting-indentation-level'},
1148 indent_columns => $rOpts->{'indent-columns'},
1149 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
1150 look_for_autoloader => $rOpts->{'look-for-autoloader'},
1151 look_for_selfloader => $rOpts->{'look-for-selfloader'},
1152 trim_qw => $rOpts->{'trim-qw'},
1153 extended_syntax => $rOpts->{'extended-syntax'},
1155 continuation_indentation =>
1156 $rOpts->{'continuation-indentation'},
1157 outdent_labels => $rOpts->{'outdent-labels'},
1160 #---------------------------------------------------------------
1162 #---------------------------------------------------------------
1163 process_this_file( $tokenizer, $formatter );
1165 #---------------------------------------------------------------
1166 # close the input source and report errors
1167 #---------------------------------------------------------------
1168 $source_object->close_input_file();
1170 # line source for next iteration (if any) comes from the current
1171 # temporary output buffer
1172 if ( $iter < $max_iterations ) {
1174 $sink_object->close_output_file();
1176 Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
1177 $rpending_logfile_message );
1179 # stop iterations if errors or converged
1180 my $stop_now = $tokenizer->report_tokenization_errors();
1181 $stop_now ||= $tokenizer->get_unexpected_error_count();
1183 $convergence_log_message = <<EOM;
1184 Stopping iterations because of severe errors.
1187 elsif ($do_convergence_test) {
1189 my $digest = $md5_hex->($sink_buffer);
1190 if ( !$saw_md5{$digest} ) {
1191 $saw_md5{$digest} = $iter;
1195 # Deja vu, stop iterating
1197 my $iterm = $iter - 1;
1198 if ( $saw_md5{$digest} != $iterm ) {
1200 # Blinking (oscillating) between two stable
1201 # end states. This has happened in the past
1202 # but at present there are no known instances.
1203 $convergence_log_message = <<EOM;
1204 Blinking. Output for iteration $iter same as for $saw_md5{$digest}.
1206 $diagnostics_object->write_diagnostics(
1207 $convergence_log_message)
1208 if $diagnostics_object;
1211 $convergence_log_message = <<EOM;
1212 Converged. Output for iteration $iter same as for iter $iterm.
1214 $diagnostics_object->write_diagnostics(
1215 $convergence_log_message)
1216 if $diagnostics_object && $iterm > 2;
1219 } ## end if ($do_convergence_test)
1223 # we are stopping the iterations early;
1224 # copy the output stream to its final destination
1225 $sink_object = $sink_object_final;
1226 while ( my $line = $source_object->get_line() ) {
1227 $sink_object->write_line($line);
1229 $source_object->close_input_file();
1232 } ## end if ( $iter < $max_iterations)
1233 } # end loop over iterations for one source file
1235 # restore objects which have been temporarily undefined
1236 # for second and higher iterations
1237 $debugger_object = $debugger_object_final;
1238 $logger_object = $logger_object_final;
1240 $logger_object->write_logfile_entry($convergence_log_message)
1241 if $convergence_log_message;
1243 #---------------------------------------------------------------
1244 # Perform any postfilter operation
1245 #---------------------------------------------------------------
1247 || $rOpts->{'assert-tidy'}
1248 || $rOpts->{'assert-untidy'} )
1250 $sink_object->close_output_file();
1252 Perl::Tidy::LineSink->new( $output_file, $tee_file,
1253 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
1257 ? $postfilter->($postfilter_buffer)
1258 : $postfilter_buffer;
1260 # Check if file changed if requested, but only after any postfilter
1261 if ( $rOpts->{'assert-tidy'} ) {
1262 my $digest_output = $md5_hex->($buf);
1263 if ( $digest_output ne $digest_input ) {
1264 $logger_object->warning(
1265 "assertion failure: '--assert-tidy' is set but output differs from input\n"
1269 if ( $rOpts->{'assert-untidy'} ) {
1270 my $digest_output = $md5_hex->($buf);
1271 if ( $digest_output eq $digest_input ) {
1272 $logger_object->warning(
1273 "assertion failure: '--assert-untidy' is set but output equals input\n"
1279 Perl::Tidy::LineSource->new( \$buf, $rOpts,
1280 $rpending_logfile_message );
1281 while ( my $line = $source_object->get_line() ) {
1282 $sink_object->write_line($line);
1284 $source_object->close_input_file();
1287 # Save names of the input and output files for syntax check
1288 my $ifname = $input_file;
1289 my $ofname = $output_file;
1291 #---------------------------------------------------------------
1292 # handle the -b option (backup and modify in-place)
1293 #---------------------------------------------------------------
1294 if ($in_place_modify) {
1295 unless ( -f $input_file ) {
1297 # oh, oh, no real file to backup ..
1298 # shouldn't happen because of numerous preliminary checks
1300 "problem with -b backing up input file '$input_file': not a file\n"
1303 my $backup_name = $input_file . $backup_extension;
1304 if ( -f $backup_name ) {
1305 unlink($backup_name)
1307 "unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
1311 # backup the input file
1312 # we use copy for symlinks, move for regular files
1313 if ( -l $input_file ) {
1314 File::Copy::copy( $input_file, $backup_name )
1315 or Die("File::Copy failed trying to backup source: $!");
1318 rename( $input_file, $backup_name )
1320 "problem renaming $input_file to $backup_name for -b option: $!\n"
1323 $ifname = $backup_name;
1325 # copy the output to the original input file
1326 # NOTE: it would be nice to just close $output_file and use
1327 # File::Copy::copy here, but in this case $output_file is the
1328 # handle of an open nameless temporary file so we would lose
1329 # everything if we closed it.
1330 seek( $output_file, 0, 0 )
1331 or Die("unable to rewind a temporary file for -b option: $!\n");
1332 my $fout = IO::File->new("> $input_file")
1334 "problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
1337 if ( $rOpts->{'character-encoding'}
1338 && $rOpts->{'character-encoding'} eq 'utf8' )
1340 binmode $fout, ":raw:encoding(UTF-8)";
1342 else { binmode $fout }
1345 while ( $line = $output_file->getline() ) {
1346 $fout->print($line);
1349 $output_file = $input_file;
1350 $ofname = $input_file;
1353 #---------------------------------------------------------------
1354 # clean up and report errors
1355 #---------------------------------------------------------------
1356 $sink_object->close_output_file() if $sink_object;
1357 $debugger_object->close_debug_file() if $debugger_object;
1359 # set output file permissions
1360 if ( $output_file && -f $output_file && !-l $output_file ) {
1361 if (@input_file_stat) {
1363 # Set file ownership and permissions
1364 if ( $rOpts->{'format'} eq 'tidy' ) {
1365 my ( $mode_i, $uid_i, $gid_i ) =
1366 @input_file_stat[ 2, 4, 5 ];
1367 my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
1368 my $input_file_permissions = $mode_i & oct(7777);
1369 my $output_file_permissions = $input_file_permissions;
1371 #rt128477: avoid inconsistent owner/group and suid/sgid
1372 if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
1374 # try to change owner and group to match input file if in -b mode
1375 # note: chown returns number of files successfully changed
1376 if ( $in_place_modify
1377 && chown( $uid_i, $gid_i, $output_file ) )
1379 # owner/group successfully changed
1383 # owner or group differ: do not copy suid and sgid
1384 $output_file_permissions = $mode_i & oct(777);
1385 if ( $input_file_permissions !=
1386 $output_file_permissions )
1389 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
1395 # Make the output file for rw unless we are in -b mode.
1396 # Explanation: perltidy does not unlink existing output
1397 # files before writing to them, for safety. If a
1398 # designated output file exists and is not writable,
1399 # perltidy will halt. This can prevent a data loss if a
1400 # user accidentally enters "perltidy infile -o
1401 # important_ro_file", or "perltidy infile -st
1402 # >important_ro_file". But it also means that perltidy can
1403 # get locked out of rerunning unless it marks its own
1404 # output files writable. The alternative, of always
1405 # unlinking the designated output file, is less safe and
1406 # not always possible, except in -b mode, where there is an
1407 # assumption that a previous backup can be unlinked even if
1409 if ( !$in_place_modify ) {
1410 $output_file_permissions |= oct(600);
1413 if ( !chmod( $output_file_permissions, $output_file ) ) {
1415 # couldn't change file permissions
1416 my $operm = sprintf "%04o", $output_file_permissions;
1418 "Unable to set permissions for output file '$output_file' to $operm\n"
1423 # else use default permissions for html and any other format
1427 #---------------------------------------------------------------
1428 # Do syntax check if requested and possible
1429 #---------------------------------------------------------------
1430 my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
1432 && $rOpts->{'check-syntax'}
1437 check_syntax( $ifname, $ofname, $logger_object, $rOpts );
1440 #---------------------------------------------------------------
1441 # remove the original file for in-place modify as follows:
1442 # $delete_backup=0 never
1443 # $delete_backup=1 only if no errors
1444 # $delete_backup>1 always : NOT ALLOWED, too risky, see above
1445 #---------------------------------------------------------------
1446 if ( $in_place_modify
1449 && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
1452 # As an added safety precaution, do not delete the source file
1453 # if its size has dropped from positive to zero, since this
1454 # could indicate a disaster of some kind, including a hardware
1455 # failure. Actually, this could happen if you had a file of
1456 # all comments (or pod) and deleted everything with -dac (-dap)
1458 if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
1460 "output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
1466 "unable to remove previous '$ifname' for -b option; check permissions: $!\n"
1471 $logger_object->finish( $infile_syntax_ok, $formatter )
1473 } # end of main loop to process all files
1475 # Fix for RT #130297: return a true value if anything was written to the
1476 # standard error output, even non-fatal warning messages, otherwise return
1479 # These exit codes are returned:
1480 # 0 = perltidy ran to completion with no errors
1481 # 1 = perltidy could not run to completion due to errors
1482 # 2 = perltidy ran to completion with error messages
1484 # Note that if perltidy is run with multiple files, any single file with
1485 # errors or warnings will write a line like
1486 # '## Please see file testing.t.ERR'
1487 # to standard output for each file with errors, so the flag will be true,
1488 # even only some of the multiple files may have had errors.
1491 my $ret = $Warn_count ? 2 : 0;
1496 } # end of main program perltidy
1498 sub get_stream_as_named_file {
1500 # Return the name of a file containing a stream of data, creating
1501 # a temporary file if necessary.
1503 # $stream - the name of a file or stream
1505 # $fname = name of file if possible, or undef
1506 # $if_tmpfile = true if temp file, undef if not temp file
1508 # This routine is needed for passing actual files to Perl for
1514 if ( ref($stream) ) {
1515 my ( $fh_stream, $fh_name ) =
1516 Perl::Tidy::streamhandle( $stream, 'r' );
1518 my ( $fout, $tmpnam ) = File::Temp::tempfile();
1523 while ( my $line = $fh_stream->getline() ) {
1524 $fout->print($line);
1528 $fh_stream->close();
1531 elsif ( $stream ne '-' && -f $stream ) {
1535 return ( $fname, $is_tmpfile );
1538 sub fileglob_to_re {
1540 # modified (corrected) from version in find2perl
1542 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
1543 $x =~ s#\*#.*#g; # '*' -> '.*'
1544 $x =~ s#\?#.#g; # '?' -> '.'
1545 return "^$x\\z"; # match whole word
1548 sub make_extension {
1550 # Make a file extension, including any leading '.' if necessary
1551 # The '.' may actually be an '_' under VMS
1552 my ( $extension, $default, $dot ) = @_;
1554 # Use the default if none specified
1555 $extension = $default unless ($extension);
1557 # Only extensions with these leading characters get a '.'
1558 # This rule gives the user some freedom
1559 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
1560 $extension = $dot . $extension;
1565 sub write_logfile_header {
1567 $rOpts, $logger_object, $config_file,
1568 $rraw_options, $Windows_type, $readable_options
1570 $logger_object->write_logfile_entry(
1571 "perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
1573 if ($Windows_type) {
1574 $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
1576 my $options_string = join( ' ', @{$rraw_options} );
1579 $logger_object->write_logfile_entry(
1580 "Found Configuration File >>> $config_file \n");
1582 $logger_object->write_logfile_entry(
1583 "Configuration and command line parameters for this run:\n");
1584 $logger_object->write_logfile_entry("$options_string\n");
1586 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
1587 $rOpts->{'logfile'} = 1; # force logfile to be saved
1588 $logger_object->write_logfile_entry(
1589 "Final parameter set for this run\n");
1590 $logger_object->write_logfile_entry(
1591 "------------------------------------\n");
1593 $logger_object->write_logfile_entry($readable_options);
1595 $logger_object->write_logfile_entry(
1596 "------------------------------------\n");
1598 $logger_object->write_logfile_entry(
1599 "To find error messages search for 'WARNING' with your editor\n");
1603 sub generate_options {
1605 ######################################################################
1606 # Generate and return references to:
1607 # @option_string - the list of options to be passed to Getopt::Long
1608 # @defaults - the list of default options
1609 # %expansion - a hash showing how all abbreviations are expanded
1610 # %category - a hash giving the general category of each option
1611 # %option_range - a hash giving the valid ranges of certain options
1613 # Note: a few options are not documented in the man page and usage
1614 # message. This is because these are experimental or debug options and
1615 # may or may not be retained in future versions.
1617 # Here are the undocumented flags as far as I know. Any of them
1618 # may disappear at any time. They are mainly for fine-tuning
1621 # fll --> fuzzy-line-length # a trivial parameter which gets
1622 # turned off for the extrude option
1623 # which is mainly for debugging
1624 # scl --> short-concatenation-item-length # helps break at '.'
1625 # recombine # for debugging line breaks
1626 # valign # for debugging vertical alignment
1627 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
1628 ######################################################################
1630 # here is a summary of the Getopt codes:
1631 # <none> does not take an argument
1632 # =s takes a mandatory string
1633 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
1634 # =i takes a mandatory integer
1635 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
1636 # ! does not take an argument and may be negated
1637 # i.e., -foo and -nofoo are allowed
1638 # a double dash signals the end of the options list
1640 #---------------------------------------------------------------
1641 # Define the option string passed to GetOptions.
1642 #---------------------------------------------------------------
1644 my @option_string = ();
1646 my %option_category = ();
1647 my %option_range = ();
1648 my $rexpansion = \%expansion;
1650 # names of categories in manual
1651 # leading integers will allow sorting
1652 my @category_name = (
1654 '1. Basic formatting options',
1655 '2. Code indentation control',
1656 '3. Whitespace control',
1657 '4. Comment controls',
1658 '5. Linebreak controls',
1659 '6. Controlling list formatting',
1660 '7. Retaining or ignoring existing line breaks',
1661 '8. Blank line control',
1662 '9. Other controls',
1664 '11. pod2html options',
1665 '12. Controlling HTML properties',
1669 # These options are parsed directly by perltidy:
1672 # However, they are included in the option set so that they will
1673 # be seen in the options dump.
1675 # These long option names have no abbreviations or are treated specially
1676 @option_string = qw(
1686 my $category = 13; # Debugging
1687 foreach (@option_string) {
1688 my $opt = $_; # must avoid changing the actual flag
1690 $option_category{$opt} = $category_name[$category];
1693 $category = 11; # HTML
1694 $option_category{html} = $category_name[$category];
1696 # routine to install and check options
1697 my $add_option = sub {
1698 my ( $long_name, $short_name, $flag ) = @_;
1699 push @option_string, $long_name . $flag;
1700 $option_category{$long_name} = $category_name[$category];
1702 if ( $expansion{$short_name} ) {
1703 my $existing_name = $expansion{$short_name}[0];
1705 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
1708 $expansion{$short_name} = [$long_name];
1709 if ( $flag eq '!' ) {
1710 my $nshort_name = 'n' . $short_name;
1711 my $nolong_name = 'no' . $long_name;
1712 if ( $expansion{$nshort_name} ) {
1713 my $existing_name = $expansion{$nshort_name}[0];
1715 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
1718 $expansion{$nshort_name} = [$nolong_name];
1723 # Install long option names which have a simple abbreviation.
1724 # Options with code '!' get standard negation ('no' for long names,
1725 # 'n' for abbreviations). Categories follow the manual.
1727 ###########################
1728 $category = 0; # I/O_Control
1729 ###########################
1730 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
1731 $add_option->( 'backup-file-extension', 'bext', '=s' );
1732 $add_option->( 'force-read-binary', 'f', '!' );
1733 $add_option->( 'format', 'fmt', '=s' );
1734 $add_option->( 'iterations', 'it', '=i' );
1735 $add_option->( 'logfile', 'log', '!' );
1736 $add_option->( 'logfile-gap', 'g', ':i' );
1737 $add_option->( 'outfile', 'o', '=s' );
1738 $add_option->( 'output-file-extension', 'oext', '=s' );
1739 $add_option->( 'output-path', 'opath', '=s' );
1740 $add_option->( 'profile', 'pro', '=s' );
1741 $add_option->( 'quiet', 'q', '!' );
1742 $add_option->( 'standard-error-output', 'se', '!' );
1743 $add_option->( 'standard-output', 'st', '!' );
1744 $add_option->( 'warning-output', 'w', '!' );
1745 $add_option->( 'character-encoding', 'enc', '=s' );
1747 # options which are both toggle switches and values moved here
1748 # to hide from tidyview (which does not show category 0 flags):
1749 # -ole moved here from category 1
1750 # -sil moved here from category 2
1751 $add_option->( 'output-line-ending', 'ole', '=s' );
1752 $add_option->( 'starting-indentation-level', 'sil', '=i' );
1754 ########################################
1755 $category = 1; # Basic formatting options
1756 ########################################
1757 $add_option->( 'check-syntax', 'syn', '!' );
1758 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
1759 $add_option->( 'indent-columns', 'i', '=i' );
1760 $add_option->( 'maximum-line-length', 'l', '=i' );
1761 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
1762 $add_option->( 'whitespace-cycle', 'wc', '=i' );
1763 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
1764 $add_option->( 'preserve-line-endings', 'ple', '!' );
1765 $add_option->( 'tabs', 't', '!' );
1766 $add_option->( 'default-tabsize', 'dt', '=i' );
1767 $add_option->( 'extended-syntax', 'xs', '!' );
1768 $add_option->( 'assert-tidy', 'ast', '!' );
1769 $add_option->( 'assert-untidy', 'asu', '!' );
1770 $add_option->( 'sub-alias-list', 'sal', '=s' );
1772 ########################################
1773 $category = 2; # Code indentation control
1774 ########################################
1775 $add_option->( 'continuation-indentation', 'ci', '=i' );
1776 $add_option->( 'line-up-parentheses', 'lp', '!' );
1777 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
1778 $add_option->( 'outdent-keywords', 'okw', '!' );
1779 $add_option->( 'outdent-labels', 'ola', '!' );
1780 $add_option->( 'outdent-long-quotes', 'olq', '!' );
1781 $add_option->( 'indent-closing-brace', 'icb', '!' );
1782 $add_option->( 'closing-token-indentation', 'cti', '=i' );
1783 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
1784 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
1785 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
1786 $add_option->( 'brace-left-and-indent', 'bli', '!' );
1787 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
1789 ########################################
1790 $category = 3; # Whitespace control
1791 ########################################
1792 $add_option->( 'add-semicolons', 'asc', '!' );
1793 $add_option->( 'add-whitespace', 'aws', '!' );
1794 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
1795 $add_option->( 'brace-tightness', 'bt', '=i' );
1796 $add_option->( 'delete-old-whitespace', 'dws', '!' );
1797 $add_option->( 'delete-semicolons', 'dsm', '!' );
1798 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
1799 $add_option->( 'nowant-left-space', 'nwls', '=s' );
1800 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
1801 $add_option->( 'paren-tightness', 'pt', '=i' );
1802 $add_option->( 'space-after-keyword', 'sak', '=s' );
1803 $add_option->( 'space-for-semicolon', 'sfs', '!' );
1804 $add_option->( 'space-function-paren', 'sfp', '!' );
1805 $add_option->( 'space-keyword-paren', 'skp', '!' );
1806 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
1807 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
1808 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
1809 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
1810 $add_option->( 'tight-secret-operators', 'tso', '!' );
1811 $add_option->( 'trim-qw', 'tqw', '!' );
1812 $add_option->( 'trim-pod', 'trp', '!' );
1813 $add_option->( 'want-left-space', 'wls', '=s' );
1814 $add_option->( 'want-right-space', 'wrs', '=s' );
1815 $add_option->( 'space-prototype-paren', 'spp', '=i' );
1817 ########################################
1818 $category = 4; # Comment controls
1819 ########################################
1820 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
1821 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
1822 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
1823 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
1824 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
1825 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
1826 $add_option->( 'closing-side-comments', 'csc', '!' );
1827 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
1828 $add_option->( 'format-skipping', 'fs', '!' );
1829 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
1830 $add_option->( 'format-skipping-end', 'fse', '=s' );
1831 $add_option->( 'hanging-side-comments', 'hsc', '!' );
1832 $add_option->( 'indent-block-comments', 'ibc', '!' );
1833 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
1834 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
1835 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
1836 $add_option->( 'outdent-long-comments', 'olc', '!' );
1837 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
1838 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
1839 $add_option->( 'static-block-comments', 'sbc', '!' );
1840 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
1841 $add_option->( 'static-side-comments', 'ssc', '!' );
1842 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
1844 ########################################
1845 $category = 5; # Linebreak controls
1846 ########################################
1847 $add_option->( 'add-newlines', 'anl', '!' );
1848 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
1849 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
1850 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
1851 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
1852 $add_option->( 'cuddled-else', 'ce', '!' );
1853 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
1854 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
1855 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
1856 $add_option->( 'delete-old-newlines', 'dnl', '!' );
1857 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
1858 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
1859 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
1860 $add_option->( 'opening-paren-right', 'opr', '!' );
1861 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
1862 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
1863 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
1864 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
1865 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
1866 $add_option->( 'weld-nested-containers', 'wn', '!' );
1867 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
1868 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
1869 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
1870 $add_option->( 'stack-closing-paren', 'scp', '!' );
1871 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
1872 $add_option->( 'stack-opening-block-brace', 'sobb', '!' );
1873 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
1874 $add_option->( 'stack-opening-paren', 'sop', '!' );
1875 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
1876 $add_option->( 'vertical-tightness', 'vt', '=i' );
1877 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
1878 $add_option->( 'want-break-after', 'wba', '=s' );
1879 $add_option->( 'want-break-before', 'wbb', '=s' );
1880 $add_option->( 'break-after-all-operators', 'baao', '!' );
1881 $add_option->( 'break-before-all-operators', 'bbao', '!' );
1882 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
1883 $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
1884 $add_option->( 'one-line-block-nesting', 'olbn', '=i' );
1886 ########################################
1887 $category = 6; # Controlling list formatting
1888 ########################################
1889 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
1890 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
1891 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
1893 ########################################
1894 $category = 7; # Retaining or ignoring existing line breaks
1895 ########################################
1896 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
1897 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
1898 $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
1899 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
1900 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
1901 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
1903 ########################################
1904 $category = 8; # Blank line control
1905 ########################################
1906 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
1907 $add_option->( 'blanks-before-comments', 'bbc', '!' );
1908 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
1909 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
1910 $add_option->( 'long-block-line-count', 'lbl', '=i' );
1911 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
1912 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
1914 $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
1915 $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
1916 $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
1917 $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
1918 $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
1919 $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
1920 $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
1922 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
1923 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
1924 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
1925 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
1927 ########################################
1928 $category = 9; # Other controls
1929 ########################################
1930 $add_option->( 'delete-block-comments', 'dbc', '!' );
1931 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
1932 $add_option->( 'delete-pod', 'dp', '!' );
1933 $add_option->( 'delete-side-comments', 'dsc', '!' );
1934 $add_option->( 'tee-block-comments', 'tbc', '!' );
1935 $add_option->( 'tee-pod', 'tp', '!' );
1936 $add_option->( 'tee-side-comments', 'tsc', '!' );
1937 $add_option->( 'look-for-autoloader', 'lal', '!' );
1938 $add_option->( 'look-for-hash-bang', 'x', '!' );
1939 $add_option->( 'look-for-selfloader', 'lsl', '!' );
1940 $add_option->( 'pass-version-line', 'pvl', '!' );
1942 ########################################
1943 $category = 13; # Debugging
1944 ########################################
1945 ## $add_option->( 'DIAGNOSTICS', 'I', '!' );
1946 $add_option->( 'DEBUG', 'D', '!' );
1947 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
1948 $add_option->( 'dump-defaults', 'ddf', '!' );
1949 $add_option->( 'dump-long-names', 'dln', '!' );
1950 $add_option->( 'dump-options', 'dop', '!' );
1951 $add_option->( 'dump-profile', 'dpro', '!' );
1952 $add_option->( 'dump-short-names', 'dsn', '!' );
1953 $add_option->( 'dump-token-types', 'dtt', '!' );
1954 $add_option->( 'dump-want-left-space', 'dwls', '!' );
1955 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
1956 $add_option->( 'fuzzy-line-length', 'fll', '!' );
1957 $add_option->( 'help', 'h', '' );
1958 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
1959 $add_option->( 'show-options', 'opt', '!' );
1960 $add_option->( 'timestamp', 'ts', '!' );
1961 $add_option->( 'version', 'v', '' );
1962 $add_option->( 'memoize', 'mem', '!' );
1963 $add_option->( 'file-size-order', 'fso', '!' );
1965 #---------------------------------------------------------------------
1967 # The Perl::Tidy::HtmlWriter will add its own options to the string
1968 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
1970 ########################################
1971 # Set categories 10, 11, 12
1972 ########################################
1973 # Based on their known order
1974 $category = 12; # HTML properties
1975 foreach my $opt (@option_string) {
1976 my $long_name = $opt;
1977 $long_name =~ s/(!|=.*|:.*)$//;
1978 unless ( defined( $option_category{$long_name} ) ) {
1979 if ( $long_name =~ /^html-linked/ ) {
1980 $category = 10; # HTML options
1982 elsif ( $long_name =~ /^pod2html/ ) {
1983 $category = 11; # Pod2html
1985 $option_category{$long_name} = $category_name[$category];
1989 #---------------------------------------------------------------
1990 # Assign valid ranges to certain options
1991 #---------------------------------------------------------------
1992 # In the future, these may be used to make preliminary checks
1993 # hash keys are long names
1994 # If key or value is undefined:
1995 # strings may have any value
1996 # integer ranges are >=0
1997 # If value is defined:
1998 # value is [qw(any valid words)] for strings
1999 # value is [min, max] for integers
2000 # if min is undefined, there is no lower limit
2001 # if max is undefined, there is no upper limit
2002 # Parameters not listed here have defaults
2004 'format' => [ 'tidy', 'html', 'user' ],
2005 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
2006 'character-encoding' => [ 'none', 'utf8' ],
2008 'space-backslash-quote' => [ 0, 2 ],
2010 'block-brace-tightness' => [ 0, 2 ],
2011 'brace-tightness' => [ 0, 2 ],
2012 'paren-tightness' => [ 0, 2 ],
2013 'square-bracket-tightness' => [ 0, 2 ],
2015 'block-brace-vertical-tightness' => [ 0, 2 ],
2016 'brace-vertical-tightness' => [ 0, 2 ],
2017 'brace-vertical-tightness-closing' => [ 0, 2 ],
2018 'paren-vertical-tightness' => [ 0, 2 ],
2019 'paren-vertical-tightness-closing' => [ 0, 2 ],
2020 'square-bracket-vertical-tightness' => [ 0, 2 ],
2021 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
2022 'vertical-tightness' => [ 0, 2 ],
2023 'vertical-tightness-closing' => [ 0, 2 ],
2025 'closing-brace-indentation' => [ 0, 3 ],
2026 'closing-paren-indentation' => [ 0, 3 ],
2027 'closing-square-bracket-indentation' => [ 0, 3 ],
2028 'closing-token-indentation' => [ 0, 3 ],
2030 'closing-side-comment-else-flag' => [ 0, 2 ],
2031 'comma-arrow-breakpoints' => [ 0, 5 ],
2033 'keyword-group-blanks-before' => [ 0, 2 ],
2034 'keyword-group-blanks-after' => [ 0, 2 ],
2036 'space-prototype-paren' => [ 0, 2 ],
2039 # Note: we could actually allow negative ci if someone really wants it:
2040 # $option_range{'continuation-indentation'} = [ undef, undef ];
2042 #---------------------------------------------------------------
2043 # Assign default values to the above options here, except
2044 # for 'outfile' and 'help'.
2045 # These settings should approximate the perlstyle(1) suggestions.
2046 #---------------------------------------------------------------
2051 blanks-before-blocks
2052 blanks-before-comments
2053 blank-lines-before-subs=1
2054 blank-lines-before-packages=1
2056 keyword-group-blanks-size=5
2057 keyword-group-blanks-repeat-count=0
2058 keyword-group-blanks-before=1
2059 keyword-group-blanks-after=1
2060 nokeyword-group-blanks-inside
2061 nokeyword-group-blanks-delete
2063 block-brace-tightness=0
2064 block-brace-vertical-tightness=0
2066 brace-vertical-tightness-closing=0
2067 brace-vertical-tightness=0
2068 break-at-old-logical-breakpoints
2069 break-at-old-ternary-breakpoints
2070 break-at-old-attribute-breakpoints
2071 break-at-old-keyword-breakpoints
2072 comma-arrow-breakpoints=5
2074 closing-side-comment-interval=6
2075 closing-side-comment-maximum-text=20
2076 closing-side-comment-else-flag=0
2077 closing-side-comments-balanced
2078 closing-paren-indentation=0
2079 closing-brace-indentation=0
2080 closing-square-bracket-indentation=0
2081 continuation-indentation=2
2082 cuddled-break-option=1
2087 hanging-side-comments
2088 indent-block-comments
2091 keep-old-blank-lines=1
2092 long-block-line-count=8
2095 maximum-consecutive-blank-lines=1
2096 maximum-fields-per-table=0
2097 maximum-line-length=80
2099 minimum-space-to-comment=4
2100 nobrace-left-and-indent
2102 nodelete-old-whitespace
2107 nostatic-side-comments
2110 character-encoding=none
2111 one-line-block-semicolons=1
2112 one-line-block-nesting=0
2115 outdent-long-comments
2117 paren-vertical-tightness-closing=0
2118 paren-vertical-tightness=0
2120 noweld-nested-containers
2123 short-concatenation-item-length=8
2125 space-backslash-quote=1
2126 space-prototype-paren=1
2127 square-bracket-tightness=1
2128 square-bracket-vertical-tightness-closing=0
2129 square-bracket-vertical-tightness=0
2130 static-block-comments
2134 backup-file-extension=bak
2139 html-table-of-contents
2143 push @defaults, "perl-syntax-check-flags=-c -T";
2145 #---------------------------------------------------------------
2146 # Define abbreviations which will be expanded into the above primitives.
2147 # These may be defined recursively.
2148 #---------------------------------------------------------------
2151 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
2152 'fnl' => [qw(freeze-newlines)],
2153 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
2154 'fws' => [qw(freeze-whitespace)],
2155 'freeze-blank-lines' =>
2156 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
2157 'fbl' => [qw(freeze-blank-lines)],
2158 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
2159 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
2160 'nooutdent-long-lines' =>
2161 [qw(nooutdent-long-quotes nooutdent-long-comments)],
2162 'noll' => [qw(nooutdent-long-lines)],
2163 'io' => [qw(indent-only)],
2164 'delete-all-comments' =>
2165 [qw(delete-block-comments delete-side-comments delete-pod)],
2166 'nodelete-all-comments' =>
2167 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
2168 'dac' => [qw(delete-all-comments)],
2169 'ndac' => [qw(nodelete-all-comments)],
2170 'gnu' => [qw(gnu-style)],
2171 'pbp' => [qw(perl-best-practices)],
2172 'tee-all-comments' =>
2173 [qw(tee-block-comments tee-side-comments tee-pod)],
2174 'notee-all-comments' =>
2175 [qw(notee-block-comments notee-side-comments notee-pod)],
2176 'tac' => [qw(tee-all-comments)],
2177 'ntac' => [qw(notee-all-comments)],
2178 'html' => [qw(format=html)],
2179 'nhtml' => [qw(format=tidy)],
2180 'tidy' => [qw(format=tidy)],
2182 # -cb is now a synonym for -ce
2183 'cb' => [qw(cuddled-else)],
2184 'cuddled-blocks' => [qw(cuddled-else)],
2186 'utf8' => [qw(character-encoding=utf8)],
2187 'UTF8' => [qw(character-encoding=utf8)],
2189 'swallow-optional-blank-lines' => [qw(kbl=0)],
2190 'noswallow-optional-blank-lines' => [qw(kbl=1)],
2191 'sob' => [qw(kbl=0)],
2192 'nsob' => [qw(kbl=1)],
2194 'break-after-comma-arrows' => [qw(cab=0)],
2195 'nobreak-after-comma-arrows' => [qw(cab=1)],
2196 'baa' => [qw(cab=0)],
2197 'nbaa' => [qw(cab=1)],
2199 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
2200 'bbs' => [qw(blbs=1 blbp=1)],
2201 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
2202 'nbbs' => [qw(blbs=0 blbp=0)],
2204 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
2205 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
2206 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
2207 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
2209 'break-at-old-trinary-breakpoints' => [qw(bot)],
2211 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
2212 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
2213 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
2214 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
2215 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
2217 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
2218 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
2219 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
2220 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
2221 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
2223 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2224 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2225 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2227 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2228 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2229 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2231 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2232 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2233 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2235 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2236 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2237 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2239 'otr' => [qw(opr ohbr osbr)],
2240 'opening-token-right' => [qw(opr ohbr osbr)],
2241 'notr' => [qw(nopr nohbr nosbr)],
2242 'noopening-token-right' => [qw(nopr nohbr nosbr)],
2244 'sot' => [qw(sop sohb sosb)],
2245 'nsot' => [qw(nsop nsohb nsosb)],
2246 'stack-opening-tokens' => [qw(sop sohb sosb)],
2247 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
2249 'sct' => [qw(scp schb scsb)],
2250 'stack-closing-tokens' => => [qw(scp schb scsb)],
2251 'nsct' => [qw(nscp nschb nscsb)],
2252 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
2254 'sac' => [qw(sot sct)],
2255 'nsac' => [qw(nsot nsct)],
2256 'stack-all-containers' => [qw(sot sct)],
2257 'nostack-all-containers' => [qw(nsot nsct)],
2259 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2260 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2261 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2262 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2263 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2264 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2266 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
2267 'sobb' => [qw(bbvt=2 bbvtl=*)],
2268 'nostack-opening-block-brace' => [qw(bbvt=0)],
2269 'nsobb' => [qw(bbvt=0)],
2271 'converge' => [qw(it=4)],
2272 'noconverge' => [qw(it=1)],
2273 'conv' => [qw(it=4)],
2274 'nconv' => [qw(it=1)],
2276 # 'mangle' originally deleted pod and comments, but to keep it
2277 # reversible, it no longer does. But if you really want to
2278 # delete them, just use:
2281 # An interesting use for 'mangle' is to do this:
2282 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
2283 # which will form as many one-line blocks as possible
2288 keep-old-blank-lines=0
2290 delete-old-whitespace
2293 maximum-consecutive-blank-lines=0
2294 maximum-line-length=100000
2298 noblanks-before-blocks
2299 blank-lines-before-subs=0
2300 blank-lines-before-packages=0
2305 # 'extrude' originally deleted pod and comments, but to keep it
2306 # reversible, it no longer does. But if you really want to
2307 # delete them, just use
2310 # An interesting use for 'extrude' is to do this:
2311 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
2312 # which will break up all one-line blocks.
2314 # Removed 'check-syntax' option, which is unsafe because it may execute
2315 # code in BEGIN blocks. Example 'Moose/debugger-duck_type.t'.
2321 delete-old-whitespace
2324 maximum-consecutive-blank-lines=0
2325 maximum-line-length=1
2328 noblanks-before-blocks
2329 blank-lines-before-subs=0
2330 blank-lines-before-packages=0
2337 # this style tries to follow the GNU Coding Standards (which do
2338 # not really apply to perl but which are followed by some perl
2342 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
2346 # Style suggested in Damian Conway's Perl Best Practices
2347 'perl-best-practices' => [
2348 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
2349 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
2352 # Additional styles can be added here
2355 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
2357 # Uncomment next line to dump all expansions for debugging:
2358 # dump_short_names(\%expansion);
2360 \@option_string, \@defaults, \%expansion,
2361 \%option_category, \%option_range
2364 } # end of generate_options
2366 # Memoize process_command_line. Given same @ARGV passed in, return same
2367 # values and same @ARGV back.
2368 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
2369 # up masontidy (https://metacpan.org/module/masontidy)
2371 my %process_command_line_cache;
2373 sub process_command_line {
2377 $perltidyrc_stream, $is_Windows, $Windows_type,
2378 $rpending_complaint, $dump_options_type
2381 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
2383 my $cache_key = join( chr(28), @ARGV );
2384 if ( my $result = $process_command_line_cache{$cache_key} ) {
2385 my ( $argv, @retvals ) = @{$result};
2390 my @retvals = _process_command_line(@q);
2391 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
2392 if $retvals[0]->{'memoize'};
2397 return _process_command_line(@q);
2401 # (note the underscore here)
2402 sub _process_command_line {
2405 $perltidyrc_stream, $is_Windows, $Windows_type,
2406 $rpending_complaint, $dump_options_type
2411 # Save any current Getopt::Long configuration
2412 # and set to Getopt::Long defaults. Use eval to avoid
2413 # breaking old versions of Perl without these routines.
2414 # Previous configuration is reset at the exit of this routine.
2416 eval { $glc = Getopt::Long::Configure() };
2418 eval { Getopt::Long::ConfigDefaults() };
2420 else { $glc = undef }
2423 $roption_string, $rdefaults, $rexpansion,
2424 $roption_category, $roption_range
2425 ) = generate_options();
2427 #---------------------------------------------------------------
2428 # set the defaults by passing the above list through GetOptions
2429 #---------------------------------------------------------------
2434 # do not load the defaults if we are just dumping perltidyrc
2435 unless ( $dump_options_type eq 'perltidyrc' ) {
2436 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
2438 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2440 "Programming Bug reported by 'GetOptions': error in setting default options"
2446 my @raw_options = ();
2447 my $config_file = "";
2448 my $saw_ignore_profile = 0;
2449 my $saw_dump_profile = 0;
2451 #---------------------------------------------------------------
2452 # Take a first look at the command-line parameters. Do as many
2453 # immediate dumps as possible, which can avoid confusion if the
2454 # perltidyrc file has an error.
2455 #---------------------------------------------------------------
2456 foreach my $i (@ARGV) {
2459 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
2460 $saw_ignore_profile = 1;
2463 # note: this must come before -pro and -profile, below:
2464 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
2465 $saw_dump_profile = 1;
2467 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
2470 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
2475 # resolve <dir>/.../<file>, meaning look upwards from directory
2476 if ( defined($config_file) ) {
2477 if ( my ( $start_dir, $search_file ) =
2478 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
2480 $start_dir = '.' if !$start_dir;
2481 $start_dir = Cwd::realpath($start_dir);
2482 if ( my $found_file =
2483 find_file_upwards( $start_dir, $search_file ) )
2485 $config_file = $found_file;
2489 unless ( -e $config_file ) {
2490 Warn("cannot find file given with -pro=$config_file: $!\n");
2494 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
2495 Die("usage: -pro=filename or --profile=filename, no spaces\n");
2497 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
2501 elsif ( $i =~ /^-(version|v)$/ ) {
2505 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
2506 dump_defaults( @{$rdefaults} );
2509 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
2510 dump_long_names( @{$roption_string} );
2513 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
2514 dump_short_names($rexpansion);
2517 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
2518 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
2523 if ( $saw_dump_profile && $saw_ignore_profile ) {
2524 Warn("No profile to dump because of -npro\n");
2528 #---------------------------------------------------------------
2529 # read any .perltidyrc configuration file
2530 #---------------------------------------------------------------
2531 unless ($saw_ignore_profile) {
2533 # resolve possible conflict between $perltidyrc_stream passed
2534 # as call parameter to perltidy and -pro=filename on command
2536 if ($perltidyrc_stream) {
2539 Conflict: a perltidyrc configuration file was specified both as this
2540 perltidy call parameter: $perltidyrc_stream
2541 and with this -profile=$config_file.
2542 Using -profile=$config_file.
2546 $config_file = $perltidyrc_stream;
2550 # look for a config file if we don't have one yet
2551 my $rconfig_file_chatter;
2552 ${$rconfig_file_chatter} = "";
2554 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
2555 $rpending_complaint )
2556 unless $config_file;
2558 # open any config file
2561 ( $fh_config, $config_file ) =
2562 Perl::Tidy::streamhandle( $config_file, 'r' );
2563 unless ($fh_config) {
2564 ${$rconfig_file_chatter} .=
2565 "# $config_file exists but cannot be opened\n";
2569 if ($saw_dump_profile) {
2570 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
2576 my ( $rconfig_list, $death_message ) =
2577 read_config_file( $fh_config, $config_file, $rexpansion );
2578 Die($death_message) if ($death_message);
2580 # process any .perltidyrc parameters right now so we can
2582 if ( @{$rconfig_list} ) {
2583 local @ARGV = @{$rconfig_list};
2585 expand_command_abbreviations( $rexpansion, \@raw_options,
2588 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2590 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
2594 # Anything left in this local @ARGV is an error and must be
2595 # invalid bare words from the configuration file. We cannot
2596 # check this earlier because bare words may have been valid
2597 # values for parameters. We had to wait for GetOptions to have
2601 my $str = "\'" . pop(@ARGV) . "\'";
2602 while ( my $param = pop(@ARGV) ) {
2603 if ( length($str) < 70 ) {
2604 $str .= ", '$param'";
2612 There are $count unrecognized values in the configuration file '$config_file':
2614 Use leading dashes for parameters. Use -npro to ignore this file.
2618 # Undo any options which cause premature exit. They are not
2619 # appropriate for a config file, and it could be hard to
2620 # diagnose the cause of the premature exit.
2623 dump-cuddled-block-list
2630 dump-want-left-space
2631 dump-want-right-space
2639 if ( defined( $Opts{$_} ) ) {
2641 Warn("ignoring --$_ in config file: $config_file\n");
2648 #---------------------------------------------------------------
2649 # now process the command line parameters
2650 #---------------------------------------------------------------
2651 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
2653 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
2654 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2655 Die("Error on command line; for help try 'perltidy -h'\n");
2658 # reset Getopt::Long configuration back to its previous value
2659 eval { Getopt::Long::Configure($glc) } if defined $glc;
2661 return ( \%Opts, $config_file, \@raw_options, $roption_string,
2662 $rexpansion, $roption_category, $roption_range );
2663 } # end of _process_command_line
2667 my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
2669 #---------------------------------------------------------------
2670 # check and handle any interactions among the basic options..
2671 #---------------------------------------------------------------
2673 # Since -vt, -vtc, and -cti are abbreviations, but under
2674 # msdos, an unquoted input parameter like vtc=1 will be
2675 # seen as 2 parameters, vtc and 1, so the abbreviations
2676 # won't be seen. Therefore, we will catch them here if
2679 if ( defined $rOpts->{'vertical-tightness'} ) {
2680 my $vt = $rOpts->{'vertical-tightness'};
2681 $rOpts->{'paren-vertical-tightness'} = $vt;
2682 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
2683 $rOpts->{'brace-vertical-tightness'} = $vt;
2686 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
2687 my $vtc = $rOpts->{'vertical-tightness-closing'};
2688 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
2689 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
2690 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
2693 if ( defined $rOpts->{'closing-token-indentation'} ) {
2694 my $cti = $rOpts->{'closing-token-indentation'};
2695 $rOpts->{'closing-square-bracket-indentation'} = $cti;
2696 $rOpts->{'closing-brace-indentation'} = $cti;
2697 $rOpts->{'closing-paren-indentation'} = $cti;
2700 # In quiet mode, there is no log file and hence no way to report
2701 # results of syntax check, so don't do it.
2702 if ( $rOpts->{'quiet'} ) {
2703 $rOpts->{'check-syntax'} = 0;
2706 # can't check syntax if no output
2707 if ( $rOpts->{'format'} ne 'tidy' ) {
2708 $rOpts->{'check-syntax'} = 0;
2711 # Never let Windows 9x/Me systems run syntax check -- this will prevent a
2712 # wide variety of nasty problems on these systems, because they cannot
2713 # reliably run backticks. Don't even think about changing this!
2714 if ( $rOpts->{'check-syntax'}
2716 && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
2718 $rOpts->{'check-syntax'} = 0;
2721 ###########################################################################
2722 # Added Dec 2017: Deactivating check-syntax for all systems for safety
2723 # because unexpected results can occur when code in BEGIN blocks is
2724 # executed. This flag was included to help check for perltidy mistakes,
2725 # and may still be useful for debugging. To activate for testing comment
2726 # out the next three lines. Also fix sub 'do_check_syntax' in this file.
2727 ###########################################################################
2729 $rOpts->{'check-syntax'} = 0;
2732 # It's really a bad idea to check syntax as root unless you wrote
2733 # the script yourself. FIXME: not sure if this works with VMS
2734 unless ($is_Windows) {
2736 if ( $< == 0 && $rOpts->{'check-syntax'} ) {
2737 $rOpts->{'check-syntax'} = 0;
2738 ${$rpending_complaint} .=
2739 "Syntax check deactivated for safety; you shouldn't run this as root\n";
2743 # check iteration count and quietly fix if necessary:
2744 # - iterations option only applies to code beautification mode
2745 # - the convergence check should stop most runs on iteration 2, and
2746 # virtually all on iteration 3. But we'll allow up to 6.
2747 if ( $rOpts->{'format'} ne 'tidy' ) {
2748 $rOpts->{'iterations'} = 1;
2750 elsif ( defined( $rOpts->{'iterations'} ) ) {
2751 if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
2752 elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
2755 $rOpts->{'iterations'} = 1;
2758 my $check_blank_count = sub {
2759 my ( $key, $abbrev ) = @_;
2760 if ( $rOpts->{$key} ) {
2761 if ( $rOpts->{$key} < 0 ) {
2763 Warn("negative value of $abbrev, setting 0\n");
2765 if ( $rOpts->{$key} > 100 ) {
2766 Warn("unreasonably large value of $abbrev, reducing\n");
2767 $rOpts->{$key} = 100;
2772 # check for reasonable number of blank lines and fix to avoid problems
2773 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
2774 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
2775 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
2776 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
2778 # setting a non-negative logfile gap causes logfile to be saved
2779 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
2780 $rOpts->{'logfile'} = 1;
2783 # set short-cut flag when only indentation is to be done.
2784 # Note that the user may or may not have already set the
2786 if ( !$rOpts->{'add-whitespace'}
2787 && !$rOpts->{'delete-old-whitespace'}
2788 && !$rOpts->{'add-newlines'}
2789 && !$rOpts->{'delete-old-newlines'} )
2791 $rOpts->{'indent-only'} = 1;
2794 # -isbc implies -ibc
2795 if ( $rOpts->{'indent-spaced-block-comments'} ) {
2796 $rOpts->{'indent-block-comments'} = 1;
2799 # -bli flag implies -bl
2800 if ( $rOpts->{'brace-left-and-indent'} ) {
2801 $rOpts->{'opening-brace-on-new-line'} = 1;
2804 if ( $rOpts->{'opening-brace-always-on-right'}
2805 && $rOpts->{'opening-brace-on-new-line'} )
2808 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
2809 'opening-brace-on-new-line' (-bl). Ignoring -bl.
2811 $rOpts->{'opening-brace-on-new-line'} = 0;
2814 # it simplifies things if -bl is 0 rather than undefined
2815 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
2816 $rOpts->{'opening-brace-on-new-line'} = 0;
2819 # -sbl defaults to -bl if not defined
2820 if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
2821 $rOpts->{'opening-sub-brace-on-new-line'} =
2822 $rOpts->{'opening-brace-on-new-line'};
2825 if ( $rOpts->{'entab-leading-whitespace'} ) {
2826 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
2827 Warn("-et=n must use a positive integer; ignoring -et\n");
2828 $rOpts->{'entab-leading-whitespace'} = undef;
2831 # entab leading whitespace has priority over the older 'tabs' option
2832 if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
2835 # set a default tabsize to be used in guessing the starting indentation
2836 # level if and only if this run does not use tabs and the old code does
2838 if ( $rOpts->{'default-tabsize'} ) {
2839 if ( $rOpts->{'default-tabsize'} < 0 ) {
2840 Warn("negative value of -dt, setting 0\n");
2841 $rOpts->{'default-tabsize'} = 0;
2843 if ( $rOpts->{'default-tabsize'} > 20 ) {
2844 Warn("unreasonably large value of -dt, reducing\n");
2845 $rOpts->{'default-tabsize'} = 20;
2849 $rOpts->{'default-tabsize'} = 8;
2852 # Check and clean up any sub-alias-list
2853 if ( $rOpts->{'sub-alias-list'} ) {
2854 my $sub_alias_string = $rOpts->{'sub-alias-list'};
2855 $sub_alias_string =~ s/,/ /g; # allow commas
2856 $sub_alias_string =~ s/^\s+//;
2857 $sub_alias_string =~ s/\s+$//;
2858 my @sub_alias_list = split /\s+/, $sub_alias_string;
2859 my @filtered_word_list = ('sub');
2862 # include 'sub' for later convenience
2864 foreach my $word (@sub_alias_list) {
2866 if ( $word !~ /^\w[\w\d]*$/ ) {
2867 Warn("unexpected sub alias '$word' - ignoring\n");
2869 if ( !$seen{$word} ) {
2871 push @filtered_word_list, $word;
2875 my $joined_words = join ' ', @filtered_word_list;
2876 $rOpts->{'sub-alias-list'} = join ' ', @filtered_word_list;
2879 # Define $tabsize, the number of spaces per tab for use in
2880 # guessing the indentation of source lines with leading tabs.
2881 # Assume same as for this run if tabs are used , otherwise assume
2882 # a default value, typically 8
2884 $rOpts->{'entab-leading-whitespace'}
2885 ? $rOpts->{'entab-leading-whitespace'}
2886 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
2887 : $rOpts->{'default-tabsize'};
2891 sub find_file_upwards {
2892 my ( $search_dir, $search_file ) = @_;
2894 $search_dir =~ s{/+$}{};
2895 $search_file =~ s{^/+}{};
2898 my $try_path = "$search_dir/$search_file";
2899 if ( -f $try_path ) {
2902 elsif ( $search_dir eq '/' ) {
2906 $search_dir = dirname($search_dir);
2910 # This return is for Perl-Critic.
2911 # We shouldn't get out of the while loop without a return
2915 sub expand_command_abbreviations {
2917 # go through @ARGV and expand any abbreviations
2919 my ( $rexpansion, $rraw_options, $config_file ) = @_;
2921 # set a pass limit to prevent an infinite loop;
2922 # 10 should be plenty, but it may be increased to allow deeply
2923 # nested expansions.
2924 my $max_passes = 10;
2927 # keep looping until all expansions have been converted into actual
2929 foreach my $pass_count ( 0 .. $max_passes ) {
2931 my $abbrev_count = 0;
2933 # loop over each item in @ARGV..
2934 foreach my $word (@ARGV) {
2936 # convert any leading 'no-' to just 'no'
2937 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
2939 # if it is a dash flag (instead of a file name)..
2940 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
2945 # save the raw input for debug output in case of circular refs
2946 if ( $pass_count == 0 ) {
2947 push( @{$rraw_options}, $word );
2950 # recombine abbreviation and flag, if necessary,
2951 # to allow abbreviations with arguments such as '-vt=1'
2952 if ( $rexpansion->{ $abr . $flags } ) {
2953 $abr = $abr . $flags;
2957 # if we see this dash item in the expansion hash..
2958 if ( $rexpansion->{$abr} ) {
2961 # stuff all of the words that it expands to into the
2962 # new arg list for the next pass
2963 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
2964 next unless $abbrev; # for safety; shouldn't happen
2965 push( @new_argv, '--' . $abbrev . $flags );
2969 # not in expansion hash, must be actual long name
2971 push( @new_argv, $word );
2975 # not a dash item, so just save it for the next pass
2977 push( @new_argv, $word );
2979 } # end of this pass
2981 # update parameter list @ARGV to the new one
2983 last unless ( $abbrev_count > 0 );
2985 # make sure we are not in an infinite loop
2986 if ( $pass_count == $max_passes ) {
2989 I'm tired. We seem to be in an infinite loop trying to expand aliases.
2990 Here are the raw options;
2993 my $num = @new_argv;
2996 After $max_passes passes here is ARGV
3002 After $max_passes passes ARGV has $num entries
3008 Please check your configuration file $config_file for circular-references.
3009 To deactivate it, use -npro.
3014 Program bug - circular-references in the %expansion hash, probably due to
3015 a recent program change.
3018 } # end of check for circular references
3019 } # end of loop over all passes
3023 # Debug routine -- this will dump the expansion hash
3024 sub dump_short_names {
3025 my $rexpansion = shift;
3027 List of short names. This list shows how all abbreviations are
3028 translated into other abbreviations and, eventually, into long names.
3029 New abbreviations may be defined in a .perltidyrc file.
3030 For a list of all long names, use perltidy --dump-long-names (-dln).
3031 --------------------------------------------------------------------------
3033 foreach my $abbrev ( sort keys %$rexpansion ) {
3034 my @list = @{ $rexpansion->{$abbrev} };
3035 print STDOUT "$abbrev --> @list\n";
3040 sub check_vms_filename {
3042 # given a valid filename (the perltidy input file)
3043 # create a modified filename and separator character
3046 # Contributed by Michael Cartmell
3048 my $filename = shift;
3049 my ( $base, $path ) = fileparse($filename);
3051 # remove explicit ; version
3052 $base =~ s/;-?\d*$//
3054 # remove explicit . version ie two dots in filename NB ^ escapes a dot
3055 or $base =~ s/( # begin capture $1
3056 (?:^|[^^])\. # match a dot not preceded by a caret
3057 (?: # followed by nothing
3059 .*[^^] # anything ending in a non caret
3062 \.-?\d*$ # match . version number
3065 # normalise filename, if there are no unescaped dots then append one
3066 $base .= '.' unless $base =~ /(?:^|[^^])\./;
3068 # if we don't already have an extension then we just append the extension
3069 my $separator = ( $base =~ /\.$/ ) ? "" : "_";
3070 return ( $path . $base, $separator );
3075 # TODO: are these more standard names?
3076 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
3078 # Returns a string that determines what MS OS we are on.
3079 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
3080 # Returns blank string if not an MS system.
3081 # Original code contributed by: Yves Orton
3082 # We need to know this to decide where to look for config files
3084 my $rpending_complaint = shift;
3086 return $os unless $^O =~ /win32|dos/i; # is it a MS box?
3088 # Systems built from Perl source may not have Win32.pm
3089 # But probably have Win32::GetOSVersion() anyway so the
3090 # following line is not 'required':
3091 # return $os unless eval('require Win32');
3093 # Use the standard API call to determine the version
3094 my ( $undef, $major, $minor, $build, $id );
3095 eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
3098 # NAME ID MAJOR MINOR
3099 # Windows NT 4 2 4 0
3100 # Windows 2000 2 5 0
3102 # Windows Server 2003 2 5 2
3104 return "win32s" unless $id; # If id==0 then its a win32s box.
3105 $os = { # Magic numbers from MSDN
3106 # documentation of GetOSVersion
3113 0 => "2000", # or NT 4, see below
3120 # If $os is undefined, the above code is out of date. Suggested updates
3122 unless ( defined $os ) {
3125 # Deactivated this message 20180322 because it was needlessly
3126 # causing some test scripts to fail. Need help from someone
3127 # with expertise in Windows to decide what is possible with windows.
3128 ${$rpending_complaint} .= <<EOS if (0);
3129 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
3130 We won't be able to look for a system-wide config file.
3134 # Unfortunately the logic used for the various versions isn't so clever..
3135 # so we have to handle an outside case.
3136 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
3141 ( $^O !~ /win32|dos/i )
3144 && ( $^O ne 'MacOS' );
3147 sub look_for_Windows {
3149 # determine Windows sub-type and location of
3150 # system-wide configuration files
3151 my $rpending_complaint = shift;
3152 my $is_Windows = ( $^O =~ /win32|dos/i );
3154 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
3155 return ( $is_Windows, $Windows_type );
3158 sub find_config_file {
3160 # look for a .perltidyrc configuration file
3161 # For Windows also look for a file named perltidy.ini
3162 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
3163 $rpending_complaint ) = @_;
3165 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
3167 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
3170 ${$rconfig_file_chatter} .= " $^O\n";
3173 # sub to check file existence and record all tests
3174 my $exists_config_file = sub {
3175 my $config_file = shift;
3176 return 0 unless $config_file;
3177 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
3178 return -f $config_file;
3181 # Sub to search upward for config file
3182 my $resolve_config_file = sub {
3184 # resolve <dir>/.../<file>, meaning look upwards from directory
3185 my $config_file = shift;
3187 if ( my ( $start_dir, $search_file ) =
3188 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3190 ${$rconfig_file_chatter} .=
3191 "# Searching Upward: $config_file\n";
3192 $start_dir = '.' if !$start_dir;
3193 $start_dir = Cwd::realpath($start_dir);
3194 if ( my $found_file =
3195 find_file_upwards( $start_dir, $search_file ) )
3197 $config_file = $found_file;
3198 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
3202 return $config_file;
3207 # look in current directory first
3208 $config_file = ".perltidyrc";
3209 return $config_file if $exists_config_file->($config_file);
3211 $config_file = "perltidy.ini";
3212 return $config_file if $exists_config_file->($config_file);
3215 # Default environment vars.
3216 my @envs = qw(PERLTIDY HOME);
3218 # Check the NT/2k/XP locations, first a local machine def, then a
3220 push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
3222 # Now go through the environment ...
3223 foreach my $var (@envs) {
3224 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
3225 if ( defined( $ENV{$var} ) ) {
3226 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
3228 # test ENV{ PERLTIDY } as file:
3229 if ( $var eq 'PERLTIDY' ) {
3230 $config_file = "$ENV{$var}";
3231 $config_file = $resolve_config_file->($config_file);
3232 return $config_file if $exists_config_file->($config_file);
3235 # test ENV as directory:
3236 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
3237 $config_file = $resolve_config_file->($config_file);
3238 return $config_file if $exists_config_file->($config_file);
3241 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
3242 $config_file = $resolve_config_file->($config_file);
3243 return $config_file if $exists_config_file->($config_file);
3247 ${$rconfig_file_chatter} .= "\n";
3251 # then look for a system-wide definition
3252 # where to look varies with OS
3255 if ($Windows_type) {
3256 my ( $os, $system, $allusers ) =
3257 Win_Config_Locs( $rpending_complaint, $Windows_type );
3259 # Check All Users directory, if there is one.
3260 # i.e. C:\Documents and Settings\User\perltidy.ini
3263 $config_file = catfile( $allusers, ".perltidyrc" );
3264 return $config_file if $exists_config_file->($config_file);
3266 $config_file = catfile( $allusers, "perltidy.ini" );
3267 return $config_file if $exists_config_file->($config_file);
3270 # Check system directory.
3271 # retain old code in case someone has been able to create
3272 # a file with a leading period.
3273 $config_file = catfile( $system, ".perltidyrc" );
3274 return $config_file if $exists_config_file->($config_file);
3276 $config_file = catfile( $system, "perltidy.ini" );
3277 return $config_file if $exists_config_file->($config_file);
3281 # Place to add customization code for other systems
3282 elsif ( $^O eq 'OS2' ) {
3284 elsif ( $^O eq 'MacOS' ) {
3286 elsif ( $^O eq 'VMS' ) {
3289 # Assume some kind of Unix
3292 $config_file = "/usr/local/etc/perltidyrc";
3293 return $config_file if $exists_config_file->($config_file);
3295 $config_file = "/etc/perltidyrc";
3296 return $config_file if $exists_config_file->($config_file);
3299 # Couldn't find a config file
3303 sub Win_Config_Locs {
3305 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
3306 # or undef if its not a win32 OS. In list context returns OS, System
3307 # Directory, and All Users Directory. All Users will be empty on a
3308 # 9x/Me box. Contributed by: Yves Orton.
3311 # my $rpending_complaint = shift;
3312 # my $os = (@_) ? shift : Win_OS_Type();
3314 my ( $rpending_complaint, $os ) = @_;
3315 if ( !$os ) { $os = Win_OS_Type(); }
3322 if ( $os =~ /9[58]|Me/ ) {
3323 $system = "C:/Windows";
3325 elsif ( $os =~ /NT|XP|200?/ ) {
3326 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
3329 ? "C:/WinNT/profiles/All Users/"
3330 : "C:/Documents and Settings/All Users/";
3334 # This currently would only happen on a win32s computer. I don't have
3335 # one to test, so I am unsure how to proceed. Suggestions welcome!
3336 ${$rpending_complaint} .=
3337 "I dont know a sensible place to look for config files on an $os system.\n";
3340 return wantarray ? ( $os, $system, $allusers ) : $os;
3343 sub dump_config_file {
3344 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
3345 print STDOUT "$$rconfig_file_chatter";
3347 print STDOUT "# Dump of file: '$config_file'\n";
3348 while ( my $line = $fh->getline() ) { print STDOUT $line }
3349 eval { $fh->close() };
3352 print STDOUT "# ...no config file found\n";
3357 sub read_config_file {
3359 my ( $fh, $config_file, $rexpansion ) = @_;
3360 my @config_list = ();
3362 # file is bad if non-empty $death_message is returned
3363 my $death_message = "";
3367 my $opening_brace_line;
3368 while ( my $line = $fh->getline() ) {
3371 ( $line, $death_message ) =
3372 strip_comment( $line, $config_file, $line_no );
3373 last if ($death_message);
3375 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
3380 # Look for complete or partial abbreviation definition of the form
3381 # name { body } or name { or name { body
3382 # See rules in perltidy's perldoc page
3383 # Section: Other Controls - Creating a new abbreviation
3384 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
3385 my $oldname = $name;
3386 ( $name, $body ) = ( $2, $3 );
3388 # Cannot start new abbreviation unless old abbreviation is complete
3389 last if ($opening_brace_line);
3391 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
3393 # handle a new alias definition
3394 if ( ${$rexpansion}{$name} ) {
3396 my @names = sort keys %$rexpansion;
3398 "Here is a list of all installed aliases\n(@names)\n"
3399 . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
3402 ${$rexpansion}{$name} = [];
3405 # leading opening braces not allowed
3406 elsif ( $line =~ /^{/ ) {
3407 $opening_brace_line = undef;
3409 "Unexpected '{' at line $line_no in config file '$config_file'\n";
3413 # Look for abbreviation closing: body } or }
3414 elsif ( $line =~ /^(.*)?\}$/ ) {
3416 if ($opening_brace_line) {
3417 $opening_brace_line = undef;
3421 "Unexpected '}' at line $line_no in config file '$config_file'\n";
3426 # Now store any parameters
3429 my ( $rbody_parts, $msg ) = parse_args($body);
3431 $death_message = <<EOM;
3432 Error reading file '$config_file' at line number $line_no.
3434 Please fix this line or use -npro to avoid reading this file
3441 # remove leading dashes if this is an alias
3442 foreach ( @{$rbody_parts} ) { s/^\-+//; }
3443 push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
3446 push( @config_list, @{$rbody_parts} );
3451 if ($opening_brace_line) {
3453 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
3455 eval { $fh->close() };
3456 return ( \@config_list, $death_message );
3461 # Strip any comment from a command line
3462 my ( $instr, $config_file, $line_no ) = @_;
3465 # check for full-line comment
3466 if ( $instr =~ /^\s*#/ ) {
3467 return ( "", $msg );
3470 # nothing to do if no comments
3471 if ( $instr !~ /#/ ) {
3472 return ( $instr, $msg );
3475 # handle case of no quotes
3476 elsif ( $instr !~ /['"]/ ) {
3478 # We now require a space before the # of a side comment
3479 # this allows something like:
3481 # Otherwise, it would have to be quoted:
3483 $instr =~ s/\s+\#.*$//;
3484 return ( $instr, $msg );
3487 # handle comments and quotes
3489 my $quote_char = "";
3492 # looking for ending quote character
3494 if ( $instr =~ /\G($quote_char)/gc ) {
3498 elsif ( $instr =~ /\G(.)/gc ) {
3502 # error..we reached the end without seeing the ending quote char
3505 Error reading file $config_file at line number $line_no.
3506 Did not see ending quote character <$quote_char> in this text:
3508 Please fix this line or use -npro to avoid reading this file
3514 # accumulating characters and looking for start of a quoted string
3516 if ( $instr =~ /\G([\"\'])/gc ) {
3521 # Note: not yet enforcing the space-before-hash rule for side
3522 # comments if the parameter is quoted.
3523 elsif ( $instr =~ /\G#/gc ) {
3526 elsif ( $instr =~ /\G(.)/gc ) {
3534 return ( $outstr, $msg );
3539 # Parse a command string containing multiple string with possible
3540 # quotes, into individual commands. It might look like this, for example:
3542 # -wba=" + - " -some-thing -wbb='. && ||'
3544 # There is no need, at present, to handle escaped quote characters.
3545 # (They are not perltidy tokens, so needn't be in strings).
3548 my @body_parts = ();
3549 my $quote_char = "";
3554 # looking for ending quote character
3556 if ( $body =~ /\G($quote_char)/gc ) {
3559 elsif ( $body =~ /\G(.)/gc ) {
3563 # error..we reached the end without seeing the ending quote char
3565 if ( length($part) ) { push @body_parts, $part; }
3567 Did not see ending quote character <$quote_char> in this text:
3574 # accumulating characters and looking for start of a quoted string
3576 if ( $body =~ /\G([\"\'])/gc ) {
3579 elsif ( $body =~ /\G(\s+)/gc ) {
3580 if ( length($part) ) { push @body_parts, $part; }
3583 elsif ( $body =~ /\G(.)/gc ) {
3587 if ( length($part) ) { push @body_parts, $part; }
3592 return ( \@body_parts, $msg );
3595 sub dump_long_names {
3599 # Command line long names (passed to GetOptions)
3600 #---------------------------------------------------------------
3601 # here is a summary of the Getopt codes:
3602 # <none> does not take an argument
3603 # =s takes a mandatory string
3604 # :s takes an optional string
3605 # =i takes a mandatory integer
3606 # :i takes an optional integer
3607 # ! does not take an argument and may be negated
3608 # i.e., -foo and -nofoo are allowed
3609 # a double dash signals the end of the options list
3611 #---------------------------------------------------------------
3614 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
3620 print STDOUT "Default command line options:\n";
3621 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
3625 sub readable_options {
3627 # return options for this run as a string which could be
3628 # put in a perltidyrc file
3629 my ( $rOpts, $roption_string ) = @_;
3631 my $rGetopt_flags = \%Getopt_flags;
3632 my $readable_options = "# Final parameter set for this run.\n";
3633 $readable_options .=
3634 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
3635 foreach my $opt ( @{$roption_string} ) {
3637 if ( $opt =~ /(.*)(!|=.*)$/ ) {
3641 if ( defined( $rOpts->{$opt} ) ) {
3642 $rGetopt_flags->{$opt} = $flag;
3645 foreach my $key ( sort keys %{$rOpts} ) {
3646 my $flag = $rGetopt_flags->{$key};
3647 my $value = $rOpts->{$key};
3651 if ( $flag =~ /^=/ ) {
3652 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
3653 $suffix = "=" . $value;
3655 elsif ( $flag =~ /^!/ ) {
3656 $prefix .= "no" unless ($value);
3661 $readable_options .=
3662 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
3665 $readable_options .= $prefix . $key . $suffix . "\n";
3667 return $readable_options;
3671 print STDOUT <<"EOM";
3672 This is perltidy, v$VERSION
3674 Copyright 2000-2019, Steve Hancock
3676 Perltidy is free software and may be copied under the terms of the GNU
3677 General Public License, which is included in the distribution files.
3679 Complete documentation for perltidy can be found using 'man perltidy'
3680 or on the internet at http://perltidy.sourceforge.net.
3688 This is perltidy version $VERSION, a perl script indenter. Usage:
3690 perltidy [ options ] file1 file2 file3 ...
3691 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
3692 perltidy [ options ] file1 -o outfile
3693 perltidy [ options ] file1 -st >outfile
3694 perltidy [ options ] <infile >outfile
3696 Options have short and long forms. Short forms are shown; see
3697 man pages for long forms. Note: '=s' indicates a required string,
3698 and '=n' indicates a required integer.
3702 -o=file name of the output file (only if single input file)
3703 -oext=s change output extension from 'tdy' to s
3704 -opath=path change path to be 'path' for output files
3705 -b backup original to .bak and modify file in-place
3706 -bext=s change default backup extension from 'bak' to s
3707 -q deactivate error messages (for running under editor)
3708 -w include non-critical warning messages in the .ERR error output
3709 -syn run perl -c to check syntax (default under unix systems)
3710 -log save .LOG file, which has useful diagnostics
3711 -f force perltidy to read a binary file
3712 -g like -log but writes more detailed .LOG file, for debugging scripts
3713 -opt write the set of options actually used to a .LOG file
3714 -npro ignore .perltidyrc configuration command file
3715 -pro=file read configuration commands from file instead of .perltidyrc
3716 -st send output to standard output, STDOUT
3717 -se send all error output to standard error output, STDERR
3718 -v display version number to standard output and quit
3721 -i=n use n columns per indentation level (default n=4)
3722 -t tabs: use one tab character per indentation level, not recommended
3723 -nt no tabs: use n spaces per indentation level (default)
3724 -et=n entab leading whitespace n spaces per tab; not recommended
3725 -io "indent only": just do indentation, no other formatting.
3726 -sil=n set starting indentation level to n; use if auto detection fails
3727 -ole=s specify output line ending (s=dos or win, mac, unix)
3728 -ple keep output line endings same as input (input must be filename)
3731 -fws freeze whitespace; this disables all whitespace changes
3732 and disables the following switches:
3733 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
3734 -bbt same as -bt but for code block braces; same as -bt if not given
3735 -bbvt block braces vertically tight; use with -bl or -bli
3736 -bbvtl=s make -bbvt to apply to selected list of block types
3737 -pt=n paren tightness (n=0, 1 or 2)
3738 -sbt=n square bracket tightness (n=0, 1, or 2)
3739 -bvt=n brace vertical tightness,
3740 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
3741 -pvt=n paren vertical tightness (see -bvt for n)
3742 -sbvt=n square bracket vertical tightness (see -bvt for n)
3743 -bvtc=n closing brace vertical tightness:
3744 n=(0=open, 1=sometimes close, 2=always close)
3745 -pvtc=n closing paren vertical tightness, see -bvtc for n.
3746 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
3747 -ci=n sets continuation indentation=n, default is n=2 spaces
3748 -lp line up parentheses, brackets, and non-BLOCK braces
3749 -sfs add space before semicolon in for( ; ; )
3750 -aws allow perltidy to add whitespace (default)
3751 -dws delete all old non-essential whitespace
3752 -icb indent closing brace of a code block
3753 -cti=n closing indentation of paren, square bracket, or non-block brace:
3754 n=0 none, =1 align with opening, =2 one full indentation level
3755 -icp equivalent to -cti=2
3756 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
3757 -wrs=s want space right of tokens in string;
3758 -sts put space before terminal semicolon of a statement
3759 -sak=s put space between keywords given in s and '(';
3760 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
3763 -fnl freeze newlines; this disables all line break changes
3764 and disables the following switches:
3765 -anl add newlines; ok to introduce new line breaks
3766 -bbs add blank line before subs and packages
3767 -bbc add blank line before block comments
3768 -bbb add blank line between major blocks
3769 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
3770 -mbl=n maximum consecutive blank lines to output (default=1)
3771 -ce cuddled else; use this style: '} else {'
3772 -cb cuddled blocks (other than 'if-elsif-else')
3773 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
3774 -dnl delete old newlines (default)
3775 -l=n maximum line length; default n=80
3776 -bl opening brace on new line
3777 -sbl opening sub brace on new line. value of -bl is used if not given.
3778 -bli opening brace on new line and indented
3779 -bar opening brace always on right, even for long clauses
3780 -vt=n vertical tightness (requires -lp); n controls break after opening
3781 token: 0=never 1=no break if next line balanced 2=no break
3782 -vtc=n vertical tightness of closing container; n controls if closing
3783 token starts new line: 0=always 1=not unless list 1=never
3784 -wba=s want break after tokens in string; i.e. wba=': .'
3785 -wbb=s want break before tokens in string
3786 -wn weld nested: combines opening and closing tokens when both are adjacent
3788 Following Old Breakpoints
3789 -kis keep interior semicolons. Allows multiple statements per line.
3790 -boc break at old comma breaks: turns off all automatic list formatting
3791 -bol break at old logical breakpoints: or, and, ||, && (default)
3792 -bom break at old method call breakpoints: ->
3793 -bok break at old list keyword breakpoints such as map, sort (default)
3794 -bot break at old conditional (ternary ?:) operator breakpoints (default)
3795 -boa break at old attribute breakpoints
3796 -cab=n break at commas after a comma-arrow (=>):
3797 n=0 break at all commas after =>
3798 n=1 stable: break unless this breaks an existing one-line container
3799 n=2 break only if a one-line container cannot be formed
3800 n=3 do not treat commas after => specially at all
3803 -ibc indent block comments (default)
3804 -isbc indent spaced block comments; may indent unless no leading space
3805 -msc=n minimum desired spaces to side comment, default 4
3806 -fpsc=n fix position for side comments; default 0;
3807 -csc add or update closing side comments after closing BLOCK brace
3808 -dcsc delete closing side comments created by a -csc command
3809 -cscp=s change closing side comment prefix to be other than '## end'
3810 -cscl=s change closing side comment to apply to selected list of blocks
3811 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
3812 -csct=n maximum number of columns of appended text, default n=20
3813 -cscw causes warning if old side comment is overwritten with -csc
3815 -sbc use 'static block comments' identified by leading '##' (default)
3816 -sbcp=s change static block comment identifier to be other than '##'
3817 -osbc outdent static block comments
3819 -ssc use 'static side comments' identified by leading '##' (default)
3820 -sscp=s change static side comment identifier to be other than '##'
3822 Delete selected text
3823 -dac delete all comments AND pod
3824 -dbc delete block comments
3825 -dsc delete side comments
3828 Send selected text to a '.TEE' file
3829 -tac tee all comments AND pod
3830 -tbc tee block comments
3831 -tsc tee side comments
3835 -olq outdent long quoted strings (default)
3836 -olc outdent a long block comment line
3837 -ola outdent statement labels
3838 -okw outdent control keywords (redo, next, last, goto, return)
3839 -okwl=s specify alternative keywords for -okw command
3842 -mft=n maximum fields per table; default n=40
3843 -x do not format lines before hash-bang line (i.e., for VMS)
3844 -asc allows perltidy to add a ';' when missing (default)
3845 -dsm allows perltidy to delete an unnecessary ';' (default)
3847 Combinations of other parameters
3848 -gnu attempt to follow GNU Coding Standards as applied to perl
3849 -mangle remove as many newlines as possible (but keep comments and pods)
3850 -extrude insert as many newlines as possible
3852 Dump and die, debugging
3853 -dop dump options used in this run to standard output and quit
3854 -ddf dump default options to standard output and quit
3855 -dsn dump all option short names to standard output and quit
3856 -dln dump option long names to standard output and quit
3857 -dpro dump whatever configuration file is in effect to standard output
3858 -dtt dump all token types to standard output and quit
3861 -html write an html file (see 'man perl2web' for many options)
3862 Note: when -html is used, no indentation or formatting are done.
3863 Hint: try perltidy -html -css=mystyle.css filename.pl
3864 and edit mystyle.css to change the appearance of filename.html.
3865 -nnn gives line numbers
3866 -pre only writes out <pre>..</pre> code section
3867 -toc places a table of contents to subs at the top (default)
3868 -pod passes pod text through pod2html (default)
3869 -frm write html as a frame (3 files)
3870 -text=s extra extension for table of contents if -frm, default='toc'
3871 -sext=s extra extension for file content if -frm, default='src'
3873 A prefix of "n" negates short form toggle switches, and a prefix of "no"
3874 negates the long forms. For example, -nasc means don't add missing
3877 If you are unable to see this entire text, try "perltidy -h | more"
3878 For more detailed information, and additional options, try "man perltidy",
3879 or go to the perltidy home page at http://perltidy.sourceforge.net
3885 sub process_this_file {
3887 my ( $tokenizer, $formatter ) = @_;
3889 while ( my $line = $tokenizer->get_line() ) {
3890 $formatter->write_line($line);
3892 my $severe_error = $tokenizer->report_tokenization_errors();
3893 eval { $formatter->finish_formatting($severe_error) };
3900 # Use 'perl -c' to make sure that we did not create bad syntax
3901 # This is a very good independent check for programming errors
3903 # Given names of the input and output files, ($istream, $ostream),
3904 # we do the following:
3905 # - check syntax of the input file
3906 # - if bad, all done (could be an incomplete code snippet)
3907 # - if infile syntax ok, then check syntax of the output file;
3908 # - if outfile syntax bad, issue warning; this implies a code bug!
3909 # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
3911 my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
3912 my $infile_syntax_ok = 0;
3913 my $line_of_dashes = '-' x 42 . "\n";
3915 my $flags = $rOpts->{'perl-syntax-check-flags'};
3917 # be sure we invoke perl with -c
3918 # note: perl will accept repeated flags like '-c -c'. It is safest
3919 # to append another -c than try to find an interior bundled c, as
3920 # in -Tc, because such a 'c' might be in a quoted string, for example.
3921 if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
3923 # be sure we invoke perl with -x if requested
3924 # same comments about repeated parameters applies
3925 if ( $rOpts->{'look-for-hash-bang'} ) {
3926 if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
3929 # this shouldn't happen unless a temporary file couldn't be made
3930 if ( $istream eq '-' ) {
3931 $logger_object->write_logfile_entry(
3932 "Cannot run perl -c on STDIN and STDOUT\n");
3933 return $infile_syntax_ok;
3936 $logger_object->write_logfile_entry(
3937 "checking input file syntax with perl $flags\n");
3939 # Not all operating systems/shells support redirection of the standard
3941 my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
3943 my ( $istream_filename, $perl_output ) =
3944 do_syntax_check( $istream, $flags, $error_redirection );
3945 $logger_object->write_logfile_entry(
3946 "Input stream passed to Perl as file $istream_filename\n");
3947 $logger_object->write_logfile_entry($line_of_dashes);
3948 $logger_object->write_logfile_entry("$perl_output\n");
3950 if ( $perl_output =~ /syntax\s*OK/ ) {
3951 $infile_syntax_ok = 1;
3952 $logger_object->write_logfile_entry($line_of_dashes);
3953 $logger_object->write_logfile_entry(
3954 "checking output file syntax with perl $flags ...\n");
3955 my ( $ostream_filename, $perl_output ) =
3956 do_syntax_check( $ostream, $flags, $error_redirection );
3957 $logger_object->write_logfile_entry(
3958 "Output stream passed to Perl as file $ostream_filename\n");
3959 $logger_object->write_logfile_entry($line_of_dashes);
3960 $logger_object->write_logfile_entry("$perl_output\n");
3962 unless ( $perl_output =~ /syntax\s*OK/ ) {
3963 $logger_object->write_logfile_entry($line_of_dashes);
3964 $logger_object->warning(
3965 "The output file has a syntax error when tested with perl $flags $ostream !\n"
3967 $logger_object->warning(
3968 "This implies an error in perltidy; the file $ostream is bad\n"
3970 $logger_object->report_definite_bug();
3972 # the perl version number will be helpful for diagnosing the problem
3973 $logger_object->write_logfile_entry( $^V . "\n" );
3978 # Only warn of perl -c syntax errors. Other messages,
3979 # such as missing modules, are too common. They can be
3980 # seen by running with perltidy -w
3981 $logger_object->complain("A syntax check using perl $flags\n");
3982 $logger_object->complain(
3983 "for the output in file $istream_filename gives:\n");
3984 $logger_object->complain($line_of_dashes);
3985 $logger_object->complain("$perl_output\n");
3986 $logger_object->complain($line_of_dashes);
3987 $infile_syntax_ok = -1;
3988 $logger_object->write_logfile_entry($line_of_dashes);
3989 $logger_object->write_logfile_entry(
3990 "The output file will not be checked because of input file problems\n"
3993 return $infile_syntax_ok;
3996 sub do_syntax_check {
3998 # This should not be called; the syntax check is deactivated
3999 Die("Unexpected call for syntax check-shouldn't happen\n");