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
91 @ISA = qw( Exporter );
92 @EXPORT = qw( &perltidy );
99 use File::Temp qw(tempfile);
103 # Release version is the approximate YYMMDD of the release.
104 # Development version is (Last Release).(Development Number)
106 # To make the number continually increasing, the Development Number is a 2
107 # digit number starting at 01 after a release is continually bumped along
108 # at significant points during developement. If it ever reaches 99 then the
109 # Release version must be bumped, and it is probably past time for a
112 $VERSION = '20190601';
117 # given filename and mode (r or w), create an object which:
118 # has a 'getline' method if mode='r', and
119 # has a 'print' method if mode='w'.
120 # The objects also need a 'close' method.
122 # How the object is made:
124 # if $filename is: Make object using:
125 # ---------------- -----------------
126 # '-' (STDIN if mode = 'r', STDOUT if mode='w')
128 # ARRAY ref Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
129 # STRING ref Perl::Tidy::IOScalar (formerly IO::Scalar)
131 # (check for 'print' method for 'w' mode)
132 # (check for 'getline' method for 'r' mode)
133 my ( $filename, $mode ) = @_;
135 my $ref = ref($filename);
141 if ( $ref eq 'ARRAY' ) {
142 $New = sub { Perl::Tidy::IOScalarArray->new(@_) };
144 elsif ( $ref eq 'SCALAR' ) {
145 $New = sub { Perl::Tidy::IOScalar->new(@_) };
149 # Accept an object with a getline method for reading. Note:
150 # IO::File is built-in and does not respond to the defined
151 # operator. If this causes trouble, the check can be
152 # skipped and we can just let it crash if there is no
154 if ( $mode =~ /[rR]/ ) {
156 # RT#97159; part 1 of 2: updated to use 'can'
157 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
158 if ( $ref->can('getline') ) {
159 $New = sub { $filename };
162 $New = sub { undef };
164 ------------------------------------------------------------------------
165 No 'getline' method is defined for object of class $ref
166 Please check your call to Perl::Tidy::perltidy. Trace follows.
167 ------------------------------------------------------------------------
172 # Accept an object with a print method for writing.
173 # See note above about IO::File
174 if ( $mode =~ /[wW]/ ) {
176 # RT#97159; part 2 of 2: updated to use 'can'
177 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
178 if ( $ref->can('print') ) {
179 $New = sub { $filename };
182 $New = sub { undef };
184 ------------------------------------------------------------------------
185 No 'print' method is defined for object of class $ref
186 Please check your call to Perl::Tidy::perltidy. Trace follows.
187 ------------------------------------------------------------------------
196 if ( $filename eq '-' ) {
197 $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
200 $New = sub { IO::File->new(@_) };
203 $fh = $New->( $filename, $mode )
204 or Warn("Couldn't open file:$filename in mode:$mode : $!\n");
206 return $fh, ( $ref or $filename );
209 sub find_input_line_ending {
211 # Peek at a file and return first line ending character.
212 # Return undefined value in case of any trouble.
213 my ($input_file) = @_;
216 # silently ignore input from object or stdin
217 if ( ref($input_file) || $input_file eq '-' ) {
222 open( $fh, '<', $input_file ) || return $ending;
226 read( $fh, $buf, 1024 );
228 if ( $buf && $buf =~ /([\012\015]+)/ ) {
232 if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
235 elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
238 elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
252 # concatenate a path and file basename
253 # returns undef in case of error
258 eval { require File::Spec };
259 $missing_file_spec = $@;
262 # use File::Spec if we can
263 unless ($missing_file_spec) {
264 return File::Spec->catfile(@parts);
267 # Perl 5.004 systems may not have File::Spec so we'll make
268 # a simple try. We assume File::Basename is available.
269 # return if not successful.
270 my $name = pop @parts;
271 my $path = join '/', @parts;
272 my $test_file = $path . $name;
273 my ( $test_name, $test_path ) = fileparse($test_file);
274 return $test_file if ( $test_name eq $name );
275 return if ( $^O eq 'VMS' );
277 # this should work at least for Windows and Unix:
278 $test_file = $path . '/' . $name;
279 ( $test_name, $test_path ) = fileparse($test_file);
280 return $test_file if ( $test_name eq $name );
284 # Here is a map of the flow of data from the input source to the output
287 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
288 # input groups output
289 # lines tokens lines of lines lines
292 # The names correspond to the package names responsible for the unit processes.
294 # The overall process is controlled by the "main" package.
296 # LineSource is the stream of input lines
298 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
299 # if necessary. A token is any section of the input line which should be
300 # manipulated as a single entity during formatting. For example, a single
301 # ',' character is a token, and so is an entire side comment. It handles
302 # the complexities of Perl syntax, such as distinguishing between '<<' as
303 # a shift operator and as a here-document, or distinguishing between '/'
304 # as a divide symbol and as a pattern delimiter.
306 # Formatter inserts and deletes whitespace between tokens, and breaks
307 # sequences of tokens at appropriate points as output lines. It bases its
308 # decisions on the default rules as modified by any command-line options.
310 # VerticalAligner collects groups of lines together and tries to line up
311 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
313 # FileWriter simply writes lines to the output stream.
315 # The Logger package, not shown, records significant events and warning
316 # messages. It writes a .LOG file, which may be saved with a
317 # '-log' or a '-g' flag.
325 destination => undef,
332 dump_options => undef,
333 dump_options_type => undef,
334 dump_getopt_flags => undef,
335 dump_options_category => undef,
336 dump_options_range => undef,
337 dump_abbreviations => undef,
342 # don't overwrite callers ARGV
344 local *STDERR = *STDERR;
346 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
348 my @good_keys = sort keys %defaults;
349 @bad_keys = sort @bad_keys;
351 ------------------------------------------------------------------------
352 Unknown perltidy parameter : (@bad_keys)
353 perltidy only understands : (@good_keys)
354 ------------------------------------------------------------------------
359 my $get_hash_ref = sub {
361 my $hash_ref = $input_hash{$key};
362 if ( defined($hash_ref) ) {
363 unless ( ref($hash_ref) eq 'HASH' ) {
364 my $what = ref($hash_ref);
366 $what ? "but is ref to $what" : "but is not a reference";
368 ------------------------------------------------------------------------
369 error in call to perltidy:
370 -$key must be reference to HASH $but_is
371 ------------------------------------------------------------------------
378 %input_hash = ( %defaults, %input_hash );
379 my $argv = $input_hash{'argv'};
380 my $destination_stream = $input_hash{'destination'};
381 my $errorfile_stream = $input_hash{'errorfile'};
382 my $logfile_stream = $input_hash{'logfile'};
383 my $perltidyrc_stream = $input_hash{'perltidyrc'};
384 my $source_stream = $input_hash{'source'};
385 my $stderr_stream = $input_hash{'stderr'};
386 my $user_formatter = $input_hash{'formatter'};
387 my $prefilter = $input_hash{'prefilter'};
388 my $postfilter = $input_hash{'postfilter'};
390 if ($stderr_stream) {
391 ( $fh_stderr, my $stderr_file ) =
392 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
395 ------------------------------------------------------------------------
396 Unable to redirect STDERR to $stderr_stream
397 Please check value of -stderr in call to perltidy
398 ------------------------------------------------------------------------
403 $fh_stderr = *STDERR;
406 sub Warn { my $msg = shift; $fh_stderr->print($msg); return }
410 if ($flag) { goto ERROR_EXIT }
411 else { goto NORMAL_EXIT }
412 croak "unexpectd return to Exit";
419 croak "unexpected return to Die";
422 # extract various dump parameters
423 my $dump_options_type = $input_hash{'dump_options_type'};
424 my $dump_options = $get_hash_ref->('dump_options');
425 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
426 my $dump_options_category = $get_hash_ref->('dump_options_category');
427 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
428 my $dump_options_range = $get_hash_ref->('dump_options_range');
430 # validate dump_options_type
431 if ( defined($dump_options) ) {
432 unless ( defined($dump_options_type) ) {
433 $dump_options_type = 'perltidyrc';
435 unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
437 ------------------------------------------------------------------------
438 Please check value of -dump_options_type in call to perltidy;
439 saw: '$dump_options_type'
440 expecting: 'perltidyrc' or 'full'
441 ------------------------------------------------------------------------
447 $dump_options_type = "";
450 if ($user_formatter) {
452 # if the user defines a formatter, there is no output stream,
453 # but we need a null stream to keep coding simple
454 $destination_stream = Perl::Tidy::DevNull->new();
457 # see if ARGV is overridden
458 if ( defined($argv) ) {
460 my $rargv = ref $argv;
461 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
465 if ( $rargv eq 'ARRAY' ) {
470 ------------------------------------------------------------------------
471 Please check value of -argv in call to perltidy;
472 it must be a string or ref to ARRAY but is: $rargv
473 ------------------------------------------------------------------------
480 my ( $rargv, $msg ) = parse_args($argv);
483 Error parsing this string passed to to perltidy with 'argv':
491 my $rpending_complaint;
492 ${$rpending_complaint} = "";
493 my $rpending_logfile_message;
494 ${$rpending_logfile_message} = "";
496 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
498 # VMS file names are restricted to a 40.40 format, so we append _tdy
499 # instead of .tdy, etc. (but see also sub check_vms_filename)
502 if ( $^O eq 'VMS' ) {
508 $dot_pattern = '\.'; # must escape for use in regex
511 #---------------------------------------------------------------
512 # get command line options
513 #---------------------------------------------------------------
514 my ( $rOpts, $config_file, $rraw_options, $roption_string,
515 $rexpansion, $roption_category, $roption_range )
516 = process_command_line(
517 $perltidyrc_stream, $is_Windows, $Windows_type,
518 $rpending_complaint, $dump_options_type,
521 my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
523 ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
525 #---------------------------------------------------------------
526 # Handle requests to dump information
527 #---------------------------------------------------------------
529 # return or exit immediately after all dumps
532 # Getopt parameters and their flags
533 if ( defined($dump_getopt_flags) ) {
535 foreach my $op ( @{$roption_string} ) {
544 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
548 $dump_getopt_flags->{$opt} = $flag;
552 if ( defined($dump_options_category) ) {
554 %{$dump_options_category} = %{$roption_category};
557 if ( defined($dump_options_range) ) {
559 %{$dump_options_range} = %{$roption_range};
562 if ( defined($dump_abbreviations) ) {
564 %{$dump_abbreviations} = %{$rexpansion};
567 if ( defined($dump_options) ) {
569 %{$dump_options} = %{$rOpts};
572 Exit(0) if ($quit_now);
574 # make printable string of options for this run as possible diagnostic
575 my $readable_options = readable_options( $rOpts, $roption_string );
577 # dump from command line
578 if ( $rOpts->{'dump-options'} ) {
579 print STDOUT $readable_options;
583 #---------------------------------------------------------------
584 # check parameters and their interactions
585 #---------------------------------------------------------------
587 check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
589 if ($user_formatter) {
590 $rOpts->{'format'} = 'user';
593 # there must be one entry here for every possible format
594 my %default_file_extension = (
600 $rOpts_character_encoding = $rOpts->{'character-encoding'};
602 # be sure we have a valid output format
603 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
604 my $formats = join ' ',
605 sort map { "'" . $_ . "'" } keys %default_file_extension;
606 my $fmt = $rOpts->{'format'};
607 Die("-format='$fmt' but must be one of: $formats\n");
610 my $output_extension = make_extension( $rOpts->{'output-file-extension'},
611 $default_file_extension{ $rOpts->{'format'} }, $dot );
613 # If the backup extension contains a / character then the backup should
614 # be deleted when the -b option is used. On older versions of
615 # perltidy this will generate an error message due to an illegal
618 # A backup file will still be generated but will be deleted
619 # at the end. If -bext='/' then this extension will be
620 # the default 'bak'. Otherwise it will be whatever characters
621 # remains after all '/' characters are removed. For example:
622 # -bext extension slashes
626 # '/dev/null' devnull 2 (Currently not allowed)
627 my $bext = $rOpts->{'backup-file-extension'};
628 my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
630 # At present only one forward slash is allowed. In the future multiple
631 # slashes may be allowed to allow for other options
632 if ( $delete_backup > 1 ) {
633 Die("-bext=$bext contains more than one '/'\n");
636 my $backup_extension =
637 make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
639 my $html_toc_extension =
640 make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
642 my $html_src_extension =
643 make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
645 # check for -b option;
646 # silently ignore unless beautify mode
647 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
648 && $rOpts->{'format'} eq 'tidy';
650 # Turn off -b with warnings in case of conflicts with other options.
651 # NOTE: Do this silently, without warnings, if there is a source or
652 # destination stream, or standard output is used. This is because the -b
653 # flag may have been in a .perltidyrc file and warnings break
654 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
655 if ($in_place_modify) {
656 if ( $rOpts->{'standard-output'}
657 || $destination_stream
658 || ref $source_stream
659 || $rOpts->{'outfile'}
660 || defined( $rOpts->{'output-path'} ) )
662 $in_place_modify = 0;
666 Perl::Tidy::Formatter::check_options($rOpts);
667 if ( $rOpts->{'format'} eq 'html' ) {
668 Perl::Tidy::HtmlWriter->check_options($rOpts);
671 # make the pattern of file extensions that we shouldn't touch
672 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
673 if ($output_extension) {
674 my $ext = quotemeta($output_extension);
675 $forbidden_file_extensions .= "|$ext";
677 if ( $in_place_modify && $backup_extension ) {
678 my $ext = quotemeta($backup_extension);
679 $forbidden_file_extensions .= "|$ext";
681 $forbidden_file_extensions .= ')$';
683 # Create a diagnostics object if requested;
684 # This is only useful for code development
685 my $diagnostics_object = undef;
686 if ( $rOpts->{'DIAGNOSTICS'} ) {
687 $diagnostics_object = Perl::Tidy::Diagnostics->new();
690 # no filenames should be given if input is from an array
691 if ($source_stream) {
694 "You may not specify any filenames when a source array is given\n"
698 # we'll stuff the source array into ARGV
699 unshift( @ARGV, $source_stream );
701 # No special treatment for source stream which is a filename.
702 # This will enable checks for binary files and other bad stuff.
703 $source_stream = undef unless ref($source_stream);
706 # use stdin by default if no source array and no args
708 unshift( @ARGV, '-' ) unless @ARGV;
711 #---------------------------------------------------------------
713 # main loop to process all files in argument list
714 #---------------------------------------------------------------
715 my $number_of_files = @ARGV;
716 my $formatter = undef;
717 my $tokenizer = undef;
719 # If requested, process in order of increasing file size
720 # This can significantly reduce perl's virtual memory usage during testing.
721 if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) {
724 sort { $a->[1] <=> $b->[1] }
725 map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
728 while ( my $input_file = shift @ARGV ) {
732 #---------------------------------------------------------------
733 # prepare this input stream
734 #---------------------------------------------------------------
735 if ($source_stream) {
736 $fileroot = "perltidy";
738 # If the source is from an array or string, then .LOG output
739 # is only possible if a logfile stream is specified. This prevents
740 # unexpected perltidy.LOG files.
741 if ( !defined($logfile_stream) ) {
742 $logfile_stream = Perl::Tidy::DevNull->new();
745 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
746 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
747 $in_place_modify = 0;
750 $fileroot = $input_file;
751 unless ( -e $input_file ) {
753 # file doesn't exist - check for a file glob
754 if ( $input_file =~ /([\?\*\[\{])/ ) {
756 # Windows shell may not remove quotes, so do it
757 my $input_file = $input_file;
758 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
759 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
760 my $pattern = fileglob_to_re($input_file);
762 if ( !$@ && opendir( DIR, './' ) ) {
764 grep { /$pattern/ && !-d $_ } readdir(DIR);
767 unshift @ARGV, @files;
772 Warn("skipping file: '$input_file': no matches found\n");
776 unless ( -f $input_file ) {
777 Warn("skipping file: $input_file: not a regular file\n");
781 # As a safety precaution, skip zero length files.
782 # If for example a source file got clobbered somehow,
783 # the old .tdy or .bak files might still exist so we
784 # shouldn't overwrite them with zero length files.
785 unless ( -s $input_file ) {
786 Warn("skipping file: $input_file: Zero size\n");
790 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
792 "skipping file: $input_file: Non-text (override with -f)\n"
797 # we should have a valid filename now
798 $fileroot = $input_file;
799 @input_file_stat = stat($input_file);
801 if ( $^O eq 'VMS' ) {
802 ( $fileroot, $dot ) = check_vms_filename($fileroot);
805 # add option to change path here
806 if ( defined( $rOpts->{'output-path'} ) ) {
808 my ( $base, $old_path ) = fileparse($fileroot);
809 my $new_path = $rOpts->{'output-path'};
810 unless ( -d $new_path ) {
811 unless ( mkdir $new_path, 0777 ) {
812 Die("unable to create directory $new_path: $!\n");
815 my $path = $new_path;
816 $fileroot = catfile( $path, $base );
819 ------------------------------------------------------------------------
820 Problem combining $new_path and $base to make a filename; check -opath
821 ------------------------------------------------------------------------
827 # Skip files with same extension as the output files because
828 # this can lead to a messy situation with files like
829 # script.tdy.tdy.tdy ... or worse problems ... when you
830 # rerun perltidy over and over with wildcard input.
833 && ( $input_file =~ /$forbidden_file_extensions/o
834 || $input_file eq 'DIAGNOSTICS' )
837 Warn("skipping file: $input_file: wrong extension\n");
841 # the 'source_object' supplies a method to read the input file
843 Perl::Tidy::LineSource->new( $input_file, $rOpts,
844 $rpending_logfile_message );
845 next unless ($source_object);
847 # Prefilters and postfilters: The prefilter is a code reference
848 # that will be applied to the source before tidying, and the
849 # postfilter is a code reference to the result before outputting.
852 || ( $rOpts_character_encoding
853 && $rOpts_character_encoding eq 'utf8' )
857 while ( my $line = $source_object->get_line() ) {
861 $buf = $prefilter->($buf) if $prefilter;
863 if ( $rOpts_character_encoding
864 && $rOpts_character_encoding eq 'utf8'
865 && !utf8::is_utf8($buf) )
868 $buf = Encode::decode( 'UTF-8', $buf,
869 Encode::FB_CROAK | Encode::LEAVE_SRC );
873 "skipping file: $input_file: Unable to decode source as UTF-8\n"
879 $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
880 $rpending_logfile_message );
883 # register this file name with the Diagnostics package
884 $diagnostics_object->set_input_file($input_file)
885 if $diagnostics_object;
887 #---------------------------------------------------------------
888 # prepare the output stream
889 #---------------------------------------------------------------
890 my $output_file = undef;
891 my $actual_output_extension;
893 if ( $rOpts->{'outfile'} ) {
895 if ( $number_of_files <= 1 ) {
897 if ( $rOpts->{'standard-output'} ) {
898 my $msg = "You may not use -o and -st together";
899 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
902 elsif ($destination_stream) {
904 "You may not specify a destination array and -o together\n"
907 elsif ( defined( $rOpts->{'output-path'} ) ) {
908 Die("You may not specify -o and -opath together\n");
910 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
911 Die("You may not specify -o and -oext together\n");
913 $output_file = $rOpts->{outfile};
915 # make sure user gives a file name after -o
916 if ( $output_file =~ /^-/ ) {
917 Die("You must specify a valid filename after -o\n");
920 # do not overwrite input file with -o
921 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
922 Die("Use 'perltidy -b $input_file' to modify in-place\n");
926 Die("You may not use -o with more than one input file\n");
929 elsif ( $rOpts->{'standard-output'} ) {
930 if ($destination_stream) {
932 "You may not specify a destination array and -st together\n";
933 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
938 if ( $number_of_files <= 1 ) {
941 Die("You may not use -st with more than one input file\n");
944 elsif ($destination_stream) {
945 $output_file = $destination_stream;
947 elsif ($source_stream) { # source but no destination goes to stdout
950 elsif ( $input_file eq '-' ) {
954 if ($in_place_modify) {
955 $output_file = IO::File->new_tmpfile()
956 or Die("cannot open temp file for -b option: $!\n");
959 $actual_output_extension = $output_extension;
960 $output_file = $fileroot . $output_extension;
964 # the 'sink_object' knows how to write the output file
965 my $tee_file = $fileroot . $dot . "TEE";
967 my $line_separator = $rOpts->{'output-line-ending'};
968 if ( $rOpts->{'preserve-line-endings'} ) {
969 $line_separator = find_input_line_ending($input_file);
972 # Eventually all I/O may be done with binmode, but for now it is
973 # only done when a user requests a particular line separator
974 # through the -ple or -ole flags
975 my $binmode = defined($line_separator)
976 || defined($rOpts_character_encoding);
977 $line_separator = "\n" unless defined($line_separator);
979 my ( $sink_object, $postfilter_buffer );
982 Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
983 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
987 Perl::Tidy::LineSink->new( $output_file, $tee_file,
988 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
991 #---------------------------------------------------------------
992 # initialize the error logger for this file
993 #---------------------------------------------------------------
994 my $warning_file = $fileroot . $dot . "ERR";
995 if ($errorfile_stream) { $warning_file = $errorfile_stream }
996 my $log_file = $fileroot . $dot . "LOG";
997 if ($logfile_stream) { $log_file = $logfile_stream }
1000 Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
1001 $fh_stderr, $saw_extrude );
1002 write_logfile_header(
1003 $rOpts, $logger_object, $config_file,
1004 $rraw_options, $Windows_type, $readable_options,
1006 if ( ${$rpending_logfile_message} ) {
1007 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
1009 if ( ${$rpending_complaint} ) {
1010 $logger_object->complain( ${$rpending_complaint} );
1013 #---------------------------------------------------------------
1014 # initialize the debug object, if any
1015 #---------------------------------------------------------------
1016 my $debugger_object = undef;
1017 if ( $rOpts->{DEBUG} ) {
1019 Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
1022 #---------------------------------------------------------------
1023 # loop over iterations for one source stream
1024 #---------------------------------------------------------------
1026 # We will do a convergence test if 3 or more iterations are allowed.
1027 # It would be pointless for fewer because we have to make at least
1028 # two passes before we can see if we are converged, and the test
1029 # would just slow things down.
1030 my $max_iterations = $rOpts->{'iterations'};
1031 my $convergence_log_message;
1033 my $do_convergence_test = $max_iterations > 2;
1035 # Since Digest::MD5 qw(md5_hex) has been in the earliest version of Perl
1036 # we are requiring (5.8), I have commented out this check
1037 ##? if ($do_convergence_test) {
1038 ##? eval "use Digest::MD5 qw(md5_hex)";
1039 ##? $do_convergence_test = !$@;
1041 ##? ### Trying to avoid problems with ancient versions of perl
1042 ##? ##eval { my $string = "perltidy"; utf8::encode($string) };
1043 ##? ##$do_convergence_test = $do_convergence_test && !$@;
1046 # save objects to allow redirecting output during iterations
1047 my $sink_object_final = $sink_object;
1048 my $debugger_object_final = $debugger_object;
1049 my $logger_object_final = $logger_object;
1051 foreach my $iter ( 1 .. $max_iterations ) {
1053 # send output stream to temp buffers until last iteration
1055 if ( $iter < $max_iterations ) {
1057 Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
1058 $line_separator, $rOpts, $rpending_logfile_message,
1062 $sink_object = $sink_object_final;
1065 # Save logger, debugger output only on pass 1 because:
1066 # (1) line number references must be to the starting
1067 # source, not an intermediate result, and
1068 # (2) we need to know if there are errors so we can stop the
1069 # iterations early if necessary.
1071 $debugger_object = undef;
1072 $logger_object = undef;
1075 #------------------------------------------------------------
1076 # create a formatter for this file : html writer or
1078 #------------------------------------------------------------
1080 # we have to delete any old formatter because, for safety,
1081 # the formatter will check to see that there is only one.
1084 if ($user_formatter) {
1085 $formatter = $user_formatter;
1087 elsif ( $rOpts->{'format'} eq 'html' ) {
1089 Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
1090 $actual_output_extension, $html_toc_extension,
1091 $html_src_extension );
1093 elsif ( $rOpts->{'format'} eq 'tidy' ) {
1094 $formatter = Perl::Tidy::Formatter->new(
1095 logger_object => $logger_object,
1096 diagnostics_object => $diagnostics_object,
1097 sink_object => $sink_object,
1101 Die("I don't know how to do -format=$rOpts->{'format'}\n");
1104 unless ($formatter) {
1105 Die("Unable to continue with $rOpts->{'format'} formatting\n");
1108 #---------------------------------------------------------------
1109 # create the tokenizer for this file
1110 #---------------------------------------------------------------
1111 $tokenizer = undef; # must destroy old tokenizer
1112 $tokenizer = Perl::Tidy::Tokenizer->new(
1113 source_object => $source_object,
1114 logger_object => $logger_object,
1115 debugger_object => $debugger_object,
1116 diagnostics_object => $diagnostics_object,
1117 tabsize => $tabsize,
1119 starting_level => $rOpts->{'starting-indentation-level'},
1120 indent_columns => $rOpts->{'indent-columns'},
1121 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
1122 look_for_autoloader => $rOpts->{'look-for-autoloader'},
1123 look_for_selfloader => $rOpts->{'look-for-selfloader'},
1124 trim_qw => $rOpts->{'trim-qw'},
1125 extended_syntax => $rOpts->{'extended-syntax'},
1127 continuation_indentation =>
1128 $rOpts->{'continuation-indentation'},
1129 outdent_labels => $rOpts->{'outdent-labels'},
1132 #---------------------------------------------------------------
1134 #---------------------------------------------------------------
1135 process_this_file( $tokenizer, $formatter );
1137 #---------------------------------------------------------------
1138 # close the input source and report errors
1139 #---------------------------------------------------------------
1140 $source_object->close_input_file();
1142 # line source for next iteration (if any) comes from the current
1143 # temporary output buffer
1144 if ( $iter < $max_iterations ) {
1146 $sink_object->close_output_file();
1148 Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
1149 $rpending_logfile_message );
1151 # stop iterations if errors or converged
1152 #my $stop_now = $logger_object->{_warning_count};
1153 my $stop_now = $tokenizer->report_tokenization_errors();
1155 $convergence_log_message = <<EOM;
1156 Stopping iterations because of severe errors.
1159 elsif ($do_convergence_test) {
1161 # Patch for [rt.cpan.org #88020]
1162 # Use utf8::encode since md5_hex() only operates on bytes.
1163 # my $digest = md5_hex( utf8::encode($sink_buffer) );
1165 # Note added 20180114: this patch did not work correctly.
1166 # I'm not sure why. But switching to the method
1167 # recommended in the Perl 5 documentation for Encode
1168 # worked. According to this we can either use
1169 # $octets = encode_utf8($string) or equivalently
1170 # $octets = encode("utf8",$string)
1171 # and then calculate the checksum. So:
1172 my $octets = Encode::encode( "utf8", $sink_buffer );
1173 my $digest = md5_hex($octets);
1174 if ( !$saw_md5{$digest} ) {
1175 $saw_md5{$digest} = $iter;
1179 # Deja vu, stop iterating
1181 my $iterm = $iter - 1;
1182 if ( $saw_md5{$digest} != $iterm ) {
1184 # Blinking (oscillating) between two stable
1185 # end states. This has happened in the past
1186 # but at present there are no known instances.
1187 $convergence_log_message = <<EOM;
1188 Blinking. Output for iteration $iter same as for $saw_md5{$digest}.
1190 $diagnostics_object->write_diagnostics(
1191 $convergence_log_message)
1192 if $diagnostics_object;
1195 $convergence_log_message = <<EOM;
1196 Converged. Output for iteration $iter same as for iter $iterm.
1198 $diagnostics_object->write_diagnostics(
1199 $convergence_log_message)
1200 if $diagnostics_object && $iterm > 2;
1203 } ## end if ($do_convergence_test)
1207 # we are stopping the iterations early;
1208 # copy the output stream to its final destination
1209 $sink_object = $sink_object_final;
1210 while ( my $line = $source_object->get_line() ) {
1211 $sink_object->write_line($line);
1213 $source_object->close_input_file();
1216 } ## end if ( $iter < $max_iterations)
1217 } # end loop over iterations for one source file
1219 # restore objects which have been temporarily undefined
1220 # for second and higher iterations
1221 $debugger_object = $debugger_object_final;
1222 $logger_object = $logger_object_final;
1224 $logger_object->write_logfile_entry($convergence_log_message)
1225 if $convergence_log_message;
1227 #---------------------------------------------------------------
1228 # Perform any postfilter operation
1229 #---------------------------------------------------------------
1231 $sink_object->close_output_file();
1233 Perl::Tidy::LineSink->new( $output_file, $tee_file,
1234 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
1235 my $buf = $postfilter->($postfilter_buffer);
1237 Perl::Tidy::LineSource->new( \$buf, $rOpts,
1238 $rpending_logfile_message );
1239 while ( my $line = $source_object->get_line() ) {
1240 $sink_object->write_line($line);
1242 $source_object->close_input_file();
1245 # Save names of the input and output files for syntax check
1246 my $ifname = $input_file;
1247 my $ofname = $output_file;
1249 #---------------------------------------------------------------
1250 # handle the -b option (backup and modify in-place)
1251 #---------------------------------------------------------------
1252 if ($in_place_modify) {
1253 unless ( -f $input_file ) {
1255 # oh, oh, no real file to backup ..
1256 # shouldn't happen because of numerous preliminary checks
1258 "problem with -b backing up input file '$input_file': not a file\n"
1261 my $backup_name = $input_file . $backup_extension;
1262 if ( -f $backup_name ) {
1263 unlink($backup_name)
1265 "unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
1269 # backup the input file
1270 # we use copy for symlinks, move for regular files
1271 if ( -l $input_file ) {
1272 File::Copy::copy( $input_file, $backup_name )
1273 or Die("File::Copy failed trying to backup source: $!");
1276 rename( $input_file, $backup_name )
1278 "problem renaming $input_file to $backup_name for -b option: $!\n"
1281 $ifname = $backup_name;
1283 # copy the output to the original input file
1284 # NOTE: it would be nice to just close $output_file and use
1285 # File::Copy::copy here, but in this case $output_file is the
1286 # handle of an open nameless temporary file so we would lose
1287 # everything if we closed it.
1288 seek( $output_file, 0, 0 )
1289 or Die("unable to rewind a temporary file for -b option: $!\n");
1290 my $fout = IO::File->new("> $input_file")
1292 "problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
1295 if ( $rOpts->{'character-encoding'}
1296 && $rOpts->{'character-encoding'} eq 'utf8' )
1298 binmode $fout, ":raw:encoding(UTF-8)";
1300 else { binmode $fout }
1303 while ( $line = $output_file->getline() ) {
1304 $fout->print($line);
1307 $output_file = $input_file;
1308 $ofname = $input_file;
1311 #---------------------------------------------------------------
1312 # clean up and report errors
1313 #---------------------------------------------------------------
1314 $sink_object->close_output_file() if $sink_object;
1315 $debugger_object->close_debug_file() if $debugger_object;
1317 # set output file permissions
1318 if ( $output_file && -f $output_file && !-l $output_file ) {
1319 if (@input_file_stat) {
1321 # Set file ownership and permissions
1322 if ( $rOpts->{'format'} eq 'tidy' ) {
1323 my ( $mode_i, $uid_i, $gid_i ) =
1324 @input_file_stat[ 2, 4, 5 ];
1325 my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
1326 my $input_file_permissions = $mode_i & oct(7777);
1327 my $output_file_permissions = $input_file_permissions;
1329 #rt128477: avoid inconsistent owner/group and suid/sgid
1330 if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
1332 # try to change owner and group to match input file if in -b mode
1333 # note: chown returns number of files successfully changed
1334 if ( $in_place_modify
1335 && chown( $uid_i, $gid_i, $output_file ) )
1337 # owner/group successfully changed
1341 # owner or group differ: do not copy suid and sgid
1342 $output_file_permissions = $mode_i & oct(777);
1343 if ( $input_file_permissions !=
1344 $output_file_permissions )
1347 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
1353 # Make the output file for rw unless we are in -b mode.
1354 # Explanation: perltidy does not unlink existing output
1355 # files before writing to them, for safety. If a
1356 # designated output file exists and is not writable,
1357 # perltidy will halt. This can prevent a data loss if a
1358 # user accidentally enters "perltidy infile -o
1359 # important_ro_file", or "perltidy infile -st
1360 # >important_ro_file". But it also means that perltidy can
1361 # get locked out of rerunning unless it marks its own
1362 # output files writable. The alternative, of always
1363 # unlinking the designated output file, is less safe and
1364 # not always possible, except in -b mode, where there is an
1365 # assumption that a previous backup can be unlinked even if
1367 if ( !$in_place_modify ) {
1368 $output_file_permissions |= oct(600);
1371 if ( !chmod( $output_file_permissions, $output_file ) ) {
1373 # couldn't change file permissions
1374 my $operm = sprintf "%04o", $output_file_permissions;
1376 "Unable to set permissions for output file '$output_file' to $operm\n"
1381 # else use default permissions for html and any other format
1385 #---------------------------------------------------------------
1386 # Do syntax check if requested and possible
1387 #---------------------------------------------------------------
1388 my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
1390 && $rOpts->{'check-syntax'}
1395 check_syntax( $ifname, $ofname, $logger_object, $rOpts );
1398 #---------------------------------------------------------------
1399 # remove the original file for in-place modify as follows:
1400 # $delete_backup=0 never
1401 # $delete_backup=1 only if no errors
1402 # $delete_backup>1 always : NOT ALLOWED, too risky, see above
1403 #---------------------------------------------------------------
1404 if ( $in_place_modify
1407 && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
1410 # As an added safety precaution, do not delete the source file
1411 # if its size has dropped from positive to zero, since this
1412 # could indicate a disaster of some kind, including a hardware
1413 # failure. Actually, this could happen if you had a file of
1414 # all comments (or pod) and deleted everything with -dac (-dap)
1416 if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
1418 "output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
1424 "unable to remove previous '$ifname' for -b option; check permissions: $!\n"
1429 $logger_object->finish( $infile_syntax_ok, $formatter )
1431 } # end of main loop to process all files
1438 } # end of main program perltidy
1440 sub get_stream_as_named_file {
1442 # Return the name of a file containing a stream of data, creating
1443 # a temporary file if necessary.
1445 # $stream - the name of a file or stream
1447 # $fname = name of file if possible, or undef
1448 # $if_tmpfile = true if temp file, undef if not temp file
1450 # This routine is needed for passing actual files to Perl for
1456 if ( ref($stream) ) {
1457 my ( $fh_stream, $fh_name ) =
1458 Perl::Tidy::streamhandle( $stream, 'r' );
1460 my ( $fout, $tmpnam ) = File::Temp::tempfile();
1465 while ( my $line = $fh_stream->getline() ) {
1466 $fout->print($line);
1470 $fh_stream->close();
1473 elsif ( $stream ne '-' && -f $stream ) {
1477 return ( $fname, $is_tmpfile );
1480 sub fileglob_to_re {
1482 # modified (corrected) from version in find2perl
1484 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
1485 $x =~ s#\*#.*#g; # '*' -> '.*'
1486 $x =~ s#\?#.#g; # '?' -> '.'
1487 return "^$x\\z"; # match whole word
1490 sub make_extension {
1492 # Make a file extension, including any leading '.' if necessary
1493 # The '.' may actually be an '_' under VMS
1494 my ( $extension, $default, $dot ) = @_;
1496 # Use the default if none specified
1497 $extension = $default unless ($extension);
1499 # Only extensions with these leading characters get a '.'
1500 # This rule gives the user some freedom
1501 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
1502 $extension = $dot . $extension;
1507 sub write_logfile_header {
1509 $rOpts, $logger_object, $config_file,
1510 $rraw_options, $Windows_type, $readable_options
1512 $logger_object->write_logfile_entry(
1513 "perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
1515 if ($Windows_type) {
1516 $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
1518 my $options_string = join( ' ', @{$rraw_options} );
1521 $logger_object->write_logfile_entry(
1522 "Found Configuration File >>> $config_file \n");
1524 $logger_object->write_logfile_entry(
1525 "Configuration and command line parameters for this run:\n");
1526 $logger_object->write_logfile_entry("$options_string\n");
1528 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
1529 $rOpts->{'logfile'} = 1; # force logfile to be saved
1530 $logger_object->write_logfile_entry(
1531 "Final parameter set for this run\n");
1532 $logger_object->write_logfile_entry(
1533 "------------------------------------\n");
1535 $logger_object->write_logfile_entry($readable_options);
1537 $logger_object->write_logfile_entry(
1538 "------------------------------------\n");
1540 $logger_object->write_logfile_entry(
1541 "To find error messages search for 'WARNING' with your editor\n");
1545 sub generate_options {
1547 ######################################################################
1548 # Generate and return references to:
1549 # @option_string - the list of options to be passed to Getopt::Long
1550 # @defaults - the list of default options
1551 # %expansion - a hash showing how all abbreviations are expanded
1552 # %category - a hash giving the general category of each option
1553 # %option_range - a hash giving the valid ranges of certain options
1555 # Note: a few options are not documented in the man page and usage
1556 # message. This is because these are experimental or debug options and
1557 # may or may not be retained in future versions.
1559 # Here are the undocumented flags as far as I know. Any of them
1560 # may disappear at any time. They are mainly for fine-tuning
1563 # fll --> fuzzy-line-length # a trivial parameter which gets
1564 # turned off for the extrude option
1565 # which is mainly for debugging
1566 # scl --> short-concatenation-item-length # helps break at '.'
1567 # recombine # for debugging line breaks
1568 # valign # for debugging vertical alignment
1569 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
1570 ######################################################################
1572 # here is a summary of the Getopt codes:
1573 # <none> does not take an argument
1574 # =s takes a mandatory string
1575 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
1576 # =i takes a mandatory integer
1577 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
1578 # ! does not take an argument and may be negated
1579 # i.e., -foo and -nofoo are allowed
1580 # a double dash signals the end of the options list
1582 #---------------------------------------------------------------
1583 # Define the option string passed to GetOptions.
1584 #---------------------------------------------------------------
1586 my @option_string = ();
1588 my %option_category = ();
1589 my %option_range = ();
1590 my $rexpansion = \%expansion;
1592 # names of categories in manual
1593 # leading integers will allow sorting
1594 my @category_name = (
1596 '1. Basic formatting options',
1597 '2. Code indentation control',
1598 '3. Whitespace control',
1599 '4. Comment controls',
1600 '5. Linebreak controls',
1601 '6. Controlling list formatting',
1602 '7. Retaining or ignoring existing line breaks',
1603 '8. Blank line control',
1604 '9. Other controls',
1606 '11. pod2html options',
1607 '12. Controlling HTML properties',
1611 # These options are parsed directly by perltidy:
1614 # However, they are included in the option set so that they will
1615 # be seen in the options dump.
1617 # These long option names have no abbreviations or are treated specially
1618 @option_string = qw(
1628 my $category = 13; # Debugging
1629 foreach (@option_string) {
1630 my $opt = $_; # must avoid changing the actual flag
1632 $option_category{$opt} = $category_name[$category];
1635 $category = 11; # HTML
1636 $option_category{html} = $category_name[$category];
1638 # routine to install and check options
1639 my $add_option = sub {
1640 my ( $long_name, $short_name, $flag ) = @_;
1641 push @option_string, $long_name . $flag;
1642 $option_category{$long_name} = $category_name[$category];
1644 if ( $expansion{$short_name} ) {
1645 my $existing_name = $expansion{$short_name}[0];
1647 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
1650 $expansion{$short_name} = [$long_name];
1651 if ( $flag eq '!' ) {
1652 my $nshort_name = 'n' . $short_name;
1653 my $nolong_name = 'no' . $long_name;
1654 if ( $expansion{$nshort_name} ) {
1655 my $existing_name = $expansion{$nshort_name}[0];
1657 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
1660 $expansion{$nshort_name} = [$nolong_name];
1665 # Install long option names which have a simple abbreviation.
1666 # Options with code '!' get standard negation ('no' for long names,
1667 # 'n' for abbreviations). Categories follow the manual.
1669 ###########################
1670 $category = 0; # I/O_Control
1671 ###########################
1672 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
1673 $add_option->( 'backup-file-extension', 'bext', '=s' );
1674 $add_option->( 'force-read-binary', 'f', '!' );
1675 $add_option->( 'format', 'fmt', '=s' );
1676 $add_option->( 'iterations', 'it', '=i' );
1677 $add_option->( 'logfile', 'log', '!' );
1678 $add_option->( 'logfile-gap', 'g', ':i' );
1679 $add_option->( 'outfile', 'o', '=s' );
1680 $add_option->( 'output-file-extension', 'oext', '=s' );
1681 $add_option->( 'output-path', 'opath', '=s' );
1682 $add_option->( 'profile', 'pro', '=s' );
1683 $add_option->( 'quiet', 'q', '!' );
1684 $add_option->( 'standard-error-output', 'se', '!' );
1685 $add_option->( 'standard-output', 'st', '!' );
1686 $add_option->( 'warning-output', 'w', '!' );
1687 $add_option->( 'character-encoding', 'enc', '=s' );
1689 # options which are both toggle switches and values moved here
1690 # to hide from tidyview (which does not show category 0 flags):
1691 # -ole moved here from category 1
1692 # -sil moved here from category 2
1693 $add_option->( 'output-line-ending', 'ole', '=s' );
1694 $add_option->( 'starting-indentation-level', 'sil', '=i' );
1696 ########################################
1697 $category = 1; # Basic formatting options
1698 ########################################
1699 $add_option->( 'check-syntax', 'syn', '!' );
1700 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
1701 $add_option->( 'indent-columns', 'i', '=i' );
1702 $add_option->( 'maximum-line-length', 'l', '=i' );
1703 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
1704 $add_option->( 'whitespace-cycle', 'wc', '=i' );
1705 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
1706 $add_option->( 'preserve-line-endings', 'ple', '!' );
1707 $add_option->( 'tabs', 't', '!' );
1708 $add_option->( 'default-tabsize', 'dt', '=i' );
1709 $add_option->( 'extended-syntax', 'xs', '!' );
1711 ########################################
1712 $category = 2; # Code indentation control
1713 ########################################
1714 $add_option->( 'continuation-indentation', 'ci', '=i' );
1715 $add_option->( 'line-up-parentheses', 'lp', '!' );
1716 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
1717 $add_option->( 'outdent-keywords', 'okw', '!' );
1718 $add_option->( 'outdent-labels', 'ola', '!' );
1719 $add_option->( 'outdent-long-quotes', 'olq', '!' );
1720 $add_option->( 'indent-closing-brace', 'icb', '!' );
1721 $add_option->( 'closing-token-indentation', 'cti', '=i' );
1722 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
1723 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
1724 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
1725 $add_option->( 'brace-left-and-indent', 'bli', '!' );
1726 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
1728 ########################################
1729 $category = 3; # Whitespace control
1730 ########################################
1731 $add_option->( 'add-semicolons', 'asc', '!' );
1732 $add_option->( 'add-whitespace', 'aws', '!' );
1733 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
1734 $add_option->( 'brace-tightness', 'bt', '=i' );
1735 $add_option->( 'delete-old-whitespace', 'dws', '!' );
1736 $add_option->( 'delete-semicolons', 'dsm', '!' );
1737 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
1738 $add_option->( 'nowant-left-space', 'nwls', '=s' );
1739 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
1740 $add_option->( 'paren-tightness', 'pt', '=i' );
1741 $add_option->( 'space-after-keyword', 'sak', '=s' );
1742 $add_option->( 'space-for-semicolon', 'sfs', '!' );
1743 $add_option->( 'space-function-paren', 'sfp', '!' );
1744 $add_option->( 'space-keyword-paren', 'skp', '!' );
1745 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
1746 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
1747 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
1748 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
1749 $add_option->( 'tight-secret-operators', 'tso', '!' );
1750 $add_option->( 'trim-qw', 'tqw', '!' );
1751 $add_option->( 'trim-pod', 'trp', '!' );
1752 $add_option->( 'want-left-space', 'wls', '=s' );
1753 $add_option->( 'want-right-space', 'wrs', '=s' );
1755 ########################################
1756 $category = 4; # Comment controls
1757 ########################################
1758 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
1759 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
1760 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
1761 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
1762 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
1763 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
1764 $add_option->( 'closing-side-comments', 'csc', '!' );
1765 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
1766 $add_option->( 'format-skipping', 'fs', '!' );
1767 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
1768 $add_option->( 'format-skipping-end', 'fse', '=s' );
1769 $add_option->( 'hanging-side-comments', 'hsc', '!' );
1770 $add_option->( 'indent-block-comments', 'ibc', '!' );
1771 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
1772 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
1773 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
1774 $add_option->( 'outdent-long-comments', 'olc', '!' );
1775 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
1776 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
1777 $add_option->( 'static-block-comments', 'sbc', '!' );
1778 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
1779 $add_option->( 'static-side-comments', 'ssc', '!' );
1780 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
1782 ########################################
1783 $category = 5; # Linebreak controls
1784 ########################################
1785 $add_option->( 'add-newlines', 'anl', '!' );
1786 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
1787 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
1788 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
1789 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
1790 $add_option->( 'cuddled-else', 'ce', '!' );
1791 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
1792 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
1793 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
1794 $add_option->( 'delete-old-newlines', 'dnl', '!' );
1795 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
1796 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
1797 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
1798 $add_option->( 'opening-paren-right', 'opr', '!' );
1799 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
1800 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
1801 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
1802 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
1803 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
1804 $add_option->( 'weld-nested-containers', 'wn', '!' );
1805 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
1806 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
1807 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
1808 $add_option->( 'stack-closing-paren', 'scp', '!' );
1809 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
1810 $add_option->( 'stack-opening-block-brace', 'sobb', '!' );
1811 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
1812 $add_option->( 'stack-opening-paren', 'sop', '!' );
1813 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
1814 $add_option->( 'vertical-tightness', 'vt', '=i' );
1815 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
1816 $add_option->( 'want-break-after', 'wba', '=s' );
1817 $add_option->( 'want-break-before', 'wbb', '=s' );
1818 $add_option->( 'break-after-all-operators', 'baao', '!' );
1819 $add_option->( 'break-before-all-operators', 'bbao', '!' );
1820 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
1821 $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
1823 ########################################
1824 $category = 6; # Controlling list formatting
1825 ########################################
1826 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
1827 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
1828 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
1830 ########################################
1831 $category = 7; # Retaining or ignoring existing line breaks
1832 ########################################
1833 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
1834 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
1835 $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
1836 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
1837 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
1838 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
1840 ########################################
1841 $category = 8; # Blank line control
1842 ########################################
1843 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
1844 $add_option->( 'blanks-before-comments', 'bbc', '!' );
1845 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
1846 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
1847 $add_option->( 'long-block-line-count', 'lbl', '=i' );
1848 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
1849 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
1851 $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
1852 $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
1853 $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
1854 $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
1855 $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
1856 $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
1857 $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
1859 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
1860 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
1861 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
1862 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
1864 ########################################
1865 $category = 9; # Other controls
1866 ########################################
1867 $add_option->( 'delete-block-comments', 'dbc', '!' );
1868 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
1869 $add_option->( 'delete-pod', 'dp', '!' );
1870 $add_option->( 'delete-side-comments', 'dsc', '!' );
1871 $add_option->( 'tee-block-comments', 'tbc', '!' );
1872 $add_option->( 'tee-pod', 'tp', '!' );
1873 $add_option->( 'tee-side-comments', 'tsc', '!' );
1874 $add_option->( 'look-for-autoloader', 'lal', '!' );
1875 $add_option->( 'look-for-hash-bang', 'x', '!' );
1876 $add_option->( 'look-for-selfloader', 'lsl', '!' );
1877 $add_option->( 'pass-version-line', 'pvl', '!' );
1879 ########################################
1880 $category = 13; # Debugging
1881 ########################################
1882 ## $add_option->( 'DIAGNOSTICS', 'I', '!' );
1883 $add_option->( 'DEBUG', 'D', '!' );
1884 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
1885 $add_option->( 'dump-defaults', 'ddf', '!' );
1886 $add_option->( 'dump-long-names', 'dln', '!' );
1887 $add_option->( 'dump-options', 'dop', '!' );
1888 $add_option->( 'dump-profile', 'dpro', '!' );
1889 $add_option->( 'dump-short-names', 'dsn', '!' );
1890 $add_option->( 'dump-token-types', 'dtt', '!' );
1891 $add_option->( 'dump-want-left-space', 'dwls', '!' );
1892 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
1893 $add_option->( 'fuzzy-line-length', 'fll', '!' );
1894 $add_option->( 'help', 'h', '' );
1895 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
1896 $add_option->( 'show-options', 'opt', '!' );
1897 $add_option->( 'timestamp', 'ts', '!' );
1898 $add_option->( 'version', 'v', '' );
1899 $add_option->( 'memoize', 'mem', '!' );
1900 $add_option->( 'file-size-order', 'fso', '!' );
1902 #---------------------------------------------------------------------
1904 # The Perl::Tidy::HtmlWriter will add its own options to the string
1905 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
1907 ########################################
1908 # Set categories 10, 11, 12
1909 ########################################
1910 # Based on their known order
1911 $category = 12; # HTML properties
1912 foreach my $opt (@option_string) {
1913 my $long_name = $opt;
1914 $long_name =~ s/(!|=.*|:.*)$//;
1915 unless ( defined( $option_category{$long_name} ) ) {
1916 if ( $long_name =~ /^html-linked/ ) {
1917 $category = 10; # HTML options
1919 elsif ( $long_name =~ /^pod2html/ ) {
1920 $category = 11; # Pod2html
1922 $option_category{$long_name} = $category_name[$category];
1926 #---------------------------------------------------------------
1927 # Assign valid ranges to certain options
1928 #---------------------------------------------------------------
1929 # In the future, these may be used to make preliminary checks
1930 # hash keys are long names
1931 # If key or value is undefined:
1932 # strings may have any value
1933 # integer ranges are >=0
1934 # If value is defined:
1935 # value is [qw(any valid words)] for strings
1936 # value is [min, max] for integers
1937 # if min is undefined, there is no lower limit
1938 # if max is undefined, there is no upper limit
1939 # Parameters not listed here have defaults
1941 'format' => [ 'tidy', 'html', 'user' ],
1942 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
1943 'character-encoding' => [ 'none', 'utf8' ],
1945 'space-backslash-quote' => [ 0, 2 ],
1947 'block-brace-tightness' => [ 0, 2 ],
1948 'brace-tightness' => [ 0, 2 ],
1949 'paren-tightness' => [ 0, 2 ],
1950 'square-bracket-tightness' => [ 0, 2 ],
1952 'block-brace-vertical-tightness' => [ 0, 2 ],
1953 'brace-vertical-tightness' => [ 0, 2 ],
1954 'brace-vertical-tightness-closing' => [ 0, 2 ],
1955 'paren-vertical-tightness' => [ 0, 2 ],
1956 'paren-vertical-tightness-closing' => [ 0, 2 ],
1957 'square-bracket-vertical-tightness' => [ 0, 2 ],
1958 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
1959 'vertical-tightness' => [ 0, 2 ],
1960 'vertical-tightness-closing' => [ 0, 2 ],
1962 'closing-brace-indentation' => [ 0, 3 ],
1963 'closing-paren-indentation' => [ 0, 3 ],
1964 'closing-square-bracket-indentation' => [ 0, 3 ],
1965 'closing-token-indentation' => [ 0, 3 ],
1967 'closing-side-comment-else-flag' => [ 0, 2 ],
1968 'comma-arrow-breakpoints' => [ 0, 5 ],
1970 'keyword-group-blanks-before' => [ 0, 2 ],
1971 'keyword-group-blanks-after' => [ 0, 2 ],
1974 # Note: we could actually allow negative ci if someone really wants it:
1975 # $option_range{'continuation-indentation'} = [ undef, undef ];
1977 #---------------------------------------------------------------
1978 # Assign default values to the above options here, except
1979 # for 'outfile' and 'help'.
1980 # These settings should approximate the perlstyle(1) suggestions.
1981 #---------------------------------------------------------------
1986 blanks-before-blocks
1987 blanks-before-comments
1988 blank-lines-before-subs=1
1989 blank-lines-before-packages=1
1991 keyword-group-blanks-size=5
1992 keyword-group-blanks-repeat-count=0
1993 keyword-group-blanks-before=1
1994 keyword-group-blanks-after=1
1995 nokeyword-group-blanks-inside
1996 nokeyword-group-blanks-delete
1998 block-brace-tightness=0
1999 block-brace-vertical-tightness=0
2001 brace-vertical-tightness-closing=0
2002 brace-vertical-tightness=0
2003 break-at-old-logical-breakpoints
2004 break-at-old-ternary-breakpoints
2005 break-at-old-attribute-breakpoints
2006 break-at-old-keyword-breakpoints
2007 comma-arrow-breakpoints=5
2009 closing-side-comment-interval=6
2010 closing-side-comment-maximum-text=20
2011 closing-side-comment-else-flag=0
2012 closing-side-comments-balanced
2013 closing-paren-indentation=0
2014 closing-brace-indentation=0
2015 closing-square-bracket-indentation=0
2016 continuation-indentation=2
2017 cuddled-break-option=1
2022 hanging-side-comments
2023 indent-block-comments
2026 keep-old-blank-lines=1
2027 long-block-line-count=8
2030 maximum-consecutive-blank-lines=1
2031 maximum-fields-per-table=0
2032 maximum-line-length=80
2034 minimum-space-to-comment=4
2035 nobrace-left-and-indent
2037 nodelete-old-whitespace
2042 nostatic-side-comments
2045 character-encoding=none
2046 one-line-block-semicolons=1
2049 outdent-long-comments
2051 paren-vertical-tightness-closing=0
2052 paren-vertical-tightness=0
2054 noweld-nested-containers
2057 short-concatenation-item-length=8
2059 space-backslash-quote=1
2060 square-bracket-tightness=1
2061 square-bracket-vertical-tightness-closing=0
2062 square-bracket-vertical-tightness=0
2063 static-block-comments
2067 backup-file-extension=bak
2072 html-table-of-contents
2076 push @defaults, "perl-syntax-check-flags=-c -T";
2078 #---------------------------------------------------------------
2079 # Define abbreviations which will be expanded into the above primitives.
2080 # These may be defined recursively.
2081 #---------------------------------------------------------------
2084 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
2085 'fnl' => [qw(freeze-newlines)],
2086 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
2087 'fws' => [qw(freeze-whitespace)],
2088 'freeze-blank-lines' =>
2089 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
2090 'fbl' => [qw(freeze-blank-lines)],
2091 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
2092 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
2093 'nooutdent-long-lines' =>
2094 [qw(nooutdent-long-quotes nooutdent-long-comments)],
2095 'noll' => [qw(nooutdent-long-lines)],
2096 'io' => [qw(indent-only)],
2097 'delete-all-comments' =>
2098 [qw(delete-block-comments delete-side-comments delete-pod)],
2099 'nodelete-all-comments' =>
2100 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
2101 'dac' => [qw(delete-all-comments)],
2102 'ndac' => [qw(nodelete-all-comments)],
2103 'gnu' => [qw(gnu-style)],
2104 'pbp' => [qw(perl-best-practices)],
2105 'tee-all-comments' =>
2106 [qw(tee-block-comments tee-side-comments tee-pod)],
2107 'notee-all-comments' =>
2108 [qw(notee-block-comments notee-side-comments notee-pod)],
2109 'tac' => [qw(tee-all-comments)],
2110 'ntac' => [qw(notee-all-comments)],
2111 'html' => [qw(format=html)],
2112 'nhtml' => [qw(format=tidy)],
2113 'tidy' => [qw(format=tidy)],
2115 # -cb is now a synonym for -ce
2116 'cb' => [qw(cuddled-else)],
2117 'cuddled-blocks' => [qw(cuddled-else)],
2119 'utf8' => [qw(character-encoding=utf8)],
2120 'UTF8' => [qw(character-encoding=utf8)],
2122 'swallow-optional-blank-lines' => [qw(kbl=0)],
2123 'noswallow-optional-blank-lines' => [qw(kbl=1)],
2124 'sob' => [qw(kbl=0)],
2125 'nsob' => [qw(kbl=1)],
2127 'break-after-comma-arrows' => [qw(cab=0)],
2128 'nobreak-after-comma-arrows' => [qw(cab=1)],
2129 'baa' => [qw(cab=0)],
2130 'nbaa' => [qw(cab=1)],
2132 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
2133 'bbs' => [qw(blbs=1 blbp=1)],
2134 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
2135 'nbbs' => [qw(blbs=0 blbp=0)],
2137 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
2138 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
2139 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
2140 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
2142 'break-at-old-trinary-breakpoints' => [qw(bot)],
2144 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
2145 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
2146 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
2147 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
2148 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
2150 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
2151 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
2152 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
2153 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
2154 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
2156 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2157 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2158 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2160 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2161 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2162 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2164 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2165 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2166 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2168 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2169 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2170 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2172 'otr' => [qw(opr ohbr osbr)],
2173 'opening-token-right' => [qw(opr ohbr osbr)],
2174 'notr' => [qw(nopr nohbr nosbr)],
2175 'noopening-token-right' => [qw(nopr nohbr nosbr)],
2177 'sot' => [qw(sop sohb sosb)],
2178 'nsot' => [qw(nsop nsohb nsosb)],
2179 'stack-opening-tokens' => [qw(sop sohb sosb)],
2180 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
2182 'sct' => [qw(scp schb scsb)],
2183 'stack-closing-tokens' => => [qw(scp schb scsb)],
2184 'nsct' => [qw(nscp nschb nscsb)],
2185 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
2187 'sac' => [qw(sot sct)],
2188 'nsac' => [qw(nsot nsct)],
2189 'stack-all-containers' => [qw(sot sct)],
2190 'nostack-all-containers' => [qw(nsot nsct)],
2192 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2193 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2194 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2195 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2196 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2197 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2199 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
2200 'sobb' => [qw(bbvt=2 bbvtl=*)],
2201 'nostack-opening-block-brace' => [qw(bbvt=0)],
2202 'nsobb' => [qw(bbvt=0)],
2204 'converge' => [qw(it=4)],
2205 'noconverge' => [qw(it=1)],
2206 'conv' => [qw(it=4)],
2207 'nconv' => [qw(it=1)],
2209 # 'mangle' originally deleted pod and comments, but to keep it
2210 # reversible, it no longer does. But if you really want to
2211 # delete them, just use:
2214 # An interesting use for 'mangle' is to do this:
2215 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
2216 # which will form as many one-line blocks as possible
2221 keep-old-blank-lines=0
2223 delete-old-whitespace
2226 maximum-consecutive-blank-lines=0
2227 maximum-line-length=100000
2231 noblanks-before-blocks
2232 blank-lines-before-subs=0
2233 blank-lines-before-packages=0
2238 # 'extrude' originally deleted pod and comments, but to keep it
2239 # reversible, it no longer does. But if you really want to
2240 # delete them, just use
2243 # An interesting use for 'extrude' is to do this:
2244 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
2245 # which will break up all one-line blocks.
2247 # Removed 'check-syntax' option, which is unsafe because it may execute
2248 # code in BEGIN blocks. Example 'Moose/debugger-duck_type.t'.
2254 delete-old-whitespace
2257 maximum-consecutive-blank-lines=0
2258 maximum-line-length=1
2261 noblanks-before-blocks
2262 blank-lines-before-subs=0
2263 blank-lines-before-packages=0
2270 # this style tries to follow the GNU Coding Standards (which do
2271 # not really apply to perl but which are followed by some perl
2275 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
2279 # Style suggested in Damian Conway's Perl Best Practices
2280 'perl-best-practices' => [
2281 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
2282 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
2285 # Additional styles can be added here
2288 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
2290 # Uncomment next line to dump all expansions for debugging:
2291 # dump_short_names(\%expansion);
2293 \@option_string, \@defaults, \%expansion,
2294 \%option_category, \%option_range
2297 } # end of generate_options
2299 # Memoize process_command_line. Given same @ARGV passed in, return same
2300 # values and same @ARGV back.
2301 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
2302 # up masontidy (https://metacpan.org/module/masontidy)
2304 my %process_command_line_cache;
2306 sub process_command_line {
2310 $perltidyrc_stream, $is_Windows, $Windows_type,
2311 $rpending_complaint, $dump_options_type
2314 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
2316 my $cache_key = join( chr(28), @ARGV );
2317 if ( my $result = $process_command_line_cache{$cache_key} ) {
2318 my ( $argv, @retvals ) = @{$result};
2323 my @retvals = _process_command_line(@q);
2324 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
2325 if $retvals[0]->{'memoize'};
2330 return _process_command_line(@q);
2334 # (note the underscore here)
2335 sub _process_command_line {
2338 $perltidyrc_stream, $is_Windows, $Windows_type,
2339 $rpending_complaint, $dump_options_type
2344 # Save any current Getopt::Long configuration
2345 # and set to Getopt::Long defaults. Use eval to avoid
2346 # breaking old versions of Perl without these routines.
2347 # Previous configuration is reset at the exit of this routine.
2349 eval { $glc = Getopt::Long::Configure() };
2351 eval { Getopt::Long::ConfigDefaults() };
2353 else { $glc = undef }
2356 $roption_string, $rdefaults, $rexpansion,
2357 $roption_category, $roption_range
2358 ) = generate_options();
2360 #---------------------------------------------------------------
2361 # set the defaults by passing the above list through GetOptions
2362 #---------------------------------------------------------------
2367 # do not load the defaults if we are just dumping perltidyrc
2368 unless ( $dump_options_type eq 'perltidyrc' ) {
2369 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
2371 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2373 "Programming Bug reported by 'GetOptions': error in setting default options"
2379 my @raw_options = ();
2380 my $config_file = "";
2381 my $saw_ignore_profile = 0;
2382 my $saw_dump_profile = 0;
2384 #---------------------------------------------------------------
2385 # Take a first look at the command-line parameters. Do as many
2386 # immediate dumps as possible, which can avoid confusion if the
2387 # perltidyrc file has an error.
2388 #---------------------------------------------------------------
2389 foreach my $i (@ARGV) {
2392 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
2393 $saw_ignore_profile = 1;
2396 # note: this must come before -pro and -profile, below:
2397 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
2398 $saw_dump_profile = 1;
2400 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
2403 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
2408 # resolve <dir>/.../<file>, meaning look upwards from directory
2409 if ( defined($config_file) ) {
2410 if ( my ( $start_dir, $search_file ) =
2411 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
2413 $start_dir = '.' if !$start_dir;
2414 $start_dir = Cwd::realpath($start_dir);
2415 if ( my $found_file =
2416 find_file_upwards( $start_dir, $search_file ) )
2418 $config_file = $found_file;
2422 unless ( -e $config_file ) {
2423 Warn("cannot find file given with -pro=$config_file: $!\n");
2427 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
2428 Die("usage: -pro=filename or --profile=filename, no spaces\n");
2430 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
2434 elsif ( $i =~ /^-(version|v)$/ ) {
2438 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
2439 dump_defaults( @{$rdefaults} );
2442 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
2443 dump_long_names( @{$roption_string} );
2446 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
2447 dump_short_names($rexpansion);
2450 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
2451 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
2456 if ( $saw_dump_profile && $saw_ignore_profile ) {
2457 Warn("No profile to dump because of -npro\n");
2461 #---------------------------------------------------------------
2462 # read any .perltidyrc configuration file
2463 #---------------------------------------------------------------
2464 unless ($saw_ignore_profile) {
2466 # resolve possible conflict between $perltidyrc_stream passed
2467 # as call parameter to perltidy and -pro=filename on command
2469 if ($perltidyrc_stream) {
2472 Conflict: a perltidyrc configuration file was specified both as this
2473 perltidy call parameter: $perltidyrc_stream
2474 and with this -profile=$config_file.
2475 Using -profile=$config_file.
2479 $config_file = $perltidyrc_stream;
2483 # look for a config file if we don't have one yet
2484 my $rconfig_file_chatter;
2485 ${$rconfig_file_chatter} = "";
2487 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
2488 $rpending_complaint )
2489 unless $config_file;
2491 # open any config file
2494 ( $fh_config, $config_file ) =
2495 Perl::Tidy::streamhandle( $config_file, 'r' );
2496 unless ($fh_config) {
2497 ${$rconfig_file_chatter} .=
2498 "# $config_file exists but cannot be opened\n";
2502 if ($saw_dump_profile) {
2503 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
2509 my ( $rconfig_list, $death_message ) =
2510 read_config_file( $fh_config, $config_file, $rexpansion );
2511 Die($death_message) if ($death_message);
2513 # process any .perltidyrc parameters right now so we can
2515 if ( @{$rconfig_list} ) {
2516 local @ARGV = @{$rconfig_list};
2518 expand_command_abbreviations( $rexpansion, \@raw_options,
2521 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2523 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
2527 # Anything left in this local @ARGV is an error and must be
2528 # invalid bare words from the configuration file. We cannot
2529 # check this earlier because bare words may have been valid
2530 # values for parameters. We had to wait for GetOptions to have
2534 my $str = "\'" . pop(@ARGV) . "\'";
2535 while ( my $param = pop(@ARGV) ) {
2536 if ( length($str) < 70 ) {
2537 $str .= ", '$param'";
2545 There are $count unrecognized values in the configuration file '$config_file':
2547 Use leading dashes for parameters. Use -npro to ignore this file.
2551 # Undo any options which cause premature exit. They are not
2552 # appropriate for a config file, and it could be hard to
2553 # diagnose the cause of the premature exit.
2556 dump-cuddled-block-list
2563 dump-want-left-space
2564 dump-want-right-space
2572 if ( defined( $Opts{$_} ) ) {
2574 Warn("ignoring --$_ in config file: $config_file\n");
2581 #---------------------------------------------------------------
2582 # now process the command line parameters
2583 #---------------------------------------------------------------
2584 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
2586 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
2587 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2588 Die("Error on command line; for help try 'perltidy -h'\n");
2591 # reset Getopt::Long configuration back to its previous value
2592 eval { Getopt::Long::Configure($glc) } if defined $glc;
2594 return ( \%Opts, $config_file, \@raw_options, $roption_string,
2595 $rexpansion, $roption_category, $roption_range );
2596 } # end of _process_command_line
2600 my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
2602 #---------------------------------------------------------------
2603 # check and handle any interactions among the basic options..
2604 #---------------------------------------------------------------
2606 # Since -vt, -vtc, and -cti are abbreviations, but under
2607 # msdos, an unquoted input parameter like vtc=1 will be
2608 # seen as 2 parameters, vtc and 1, so the abbreviations
2609 # won't be seen. Therefore, we will catch them here if
2612 if ( defined $rOpts->{'vertical-tightness'} ) {
2613 my $vt = $rOpts->{'vertical-tightness'};
2614 $rOpts->{'paren-vertical-tightness'} = $vt;
2615 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
2616 $rOpts->{'brace-vertical-tightness'} = $vt;
2619 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
2620 my $vtc = $rOpts->{'vertical-tightness-closing'};
2621 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
2622 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
2623 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
2626 if ( defined $rOpts->{'closing-token-indentation'} ) {
2627 my $cti = $rOpts->{'closing-token-indentation'};
2628 $rOpts->{'closing-square-bracket-indentation'} = $cti;
2629 $rOpts->{'closing-brace-indentation'} = $cti;
2630 $rOpts->{'closing-paren-indentation'} = $cti;
2633 # In quiet mode, there is no log file and hence no way to report
2634 # results of syntax check, so don't do it.
2635 if ( $rOpts->{'quiet'} ) {
2636 $rOpts->{'check-syntax'} = 0;
2639 # can't check syntax if no output
2640 if ( $rOpts->{'format'} ne 'tidy' ) {
2641 $rOpts->{'check-syntax'} = 0;
2644 # Never let Windows 9x/Me systems run syntax check -- this will prevent a
2645 # wide variety of nasty problems on these systems, because they cannot
2646 # reliably run backticks. Don't even think about changing this!
2647 if ( $rOpts->{'check-syntax'}
2649 && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
2651 $rOpts->{'check-syntax'} = 0;
2654 ###########################################################################
2655 # Added Dec 2017: Deactivating check-syntax for all systems for safety
2656 # because unexpected results can occur when code in BEGIN blocks is
2657 # executed. This flag was included to help check for perltidy mistakes,
2658 # and may still be useful for debugging. To activate for testing comment
2659 # out the next three lines. Also fix sub 'do_check_syntax' in this file.
2660 ###########################################################################
2662 $rOpts->{'check-syntax'} = 0;
2665 # It's really a bad idea to check syntax as root unless you wrote
2666 # the script yourself. FIXME: not sure if this works with VMS
2667 unless ($is_Windows) {
2669 if ( $< == 0 && $rOpts->{'check-syntax'} ) {
2670 $rOpts->{'check-syntax'} = 0;
2671 ${$rpending_complaint} .=
2672 "Syntax check deactivated for safety; you shouldn't run this as root\n";
2676 # check iteration count and quietly fix if necessary:
2677 # - iterations option only applies to code beautification mode
2678 # - the convergence check should stop most runs on iteration 2, and
2679 # virtually all on iteration 3. But we'll allow up to 6.
2680 if ( $rOpts->{'format'} ne 'tidy' ) {
2681 $rOpts->{'iterations'} = 1;
2683 elsif ( defined( $rOpts->{'iterations'} ) ) {
2684 if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
2685 elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
2688 $rOpts->{'iterations'} = 1;
2691 my $check_blank_count = sub {
2692 my ( $key, $abbrev ) = @_;
2693 if ( $rOpts->{$key} ) {
2694 if ( $rOpts->{$key} < 0 ) {
2696 Warn("negative value of $abbrev, setting 0\n");
2698 if ( $rOpts->{$key} > 100 ) {
2699 Warn("unreasonably large value of $abbrev, reducing\n");
2700 $rOpts->{$key} = 100;
2705 # check for reasonable number of blank lines and fix to avoid problems
2706 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
2707 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
2708 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
2709 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
2711 # setting a non-negative logfile gap causes logfile to be saved
2712 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
2713 $rOpts->{'logfile'} = 1;
2716 # set short-cut flag when only indentation is to be done.
2717 # Note that the user may or may not have already set the
2719 if ( !$rOpts->{'add-whitespace'}
2720 && !$rOpts->{'delete-old-whitespace'}
2721 && !$rOpts->{'add-newlines'}
2722 && !$rOpts->{'delete-old-newlines'} )
2724 $rOpts->{'indent-only'} = 1;
2727 # -isbc implies -ibc
2728 if ( $rOpts->{'indent-spaced-block-comments'} ) {
2729 $rOpts->{'indent-block-comments'} = 1;
2732 # -bli flag implies -bl
2733 if ( $rOpts->{'brace-left-and-indent'} ) {
2734 $rOpts->{'opening-brace-on-new-line'} = 1;
2737 if ( $rOpts->{'opening-brace-always-on-right'}
2738 && $rOpts->{'opening-brace-on-new-line'} )
2741 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
2742 'opening-brace-on-new-line' (-bl). Ignoring -bl.
2744 $rOpts->{'opening-brace-on-new-line'} = 0;
2747 # it simplifies things if -bl is 0 rather than undefined
2748 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
2749 $rOpts->{'opening-brace-on-new-line'} = 0;
2752 # -sbl defaults to -bl if not defined
2753 if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
2754 $rOpts->{'opening-sub-brace-on-new-line'} =
2755 $rOpts->{'opening-brace-on-new-line'};
2758 if ( $rOpts->{'entab-leading-whitespace'} ) {
2759 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
2760 Warn("-et=n must use a positive integer; ignoring -et\n");
2761 $rOpts->{'entab-leading-whitespace'} = undef;
2764 # entab leading whitespace has priority over the older 'tabs' option
2765 if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
2768 # set a default tabsize to be used in guessing the starting indentation
2769 # level if and only if this run does not use tabs and the old code does
2771 if ( $rOpts->{'default-tabsize'} ) {
2772 if ( $rOpts->{'default-tabsize'} < 0 ) {
2773 Warn("negative value of -dt, setting 0\n");
2774 $rOpts->{'default-tabsize'} = 0;
2776 if ( $rOpts->{'default-tabsize'} > 20 ) {
2777 Warn("unreasonably large value of -dt, reducing\n");
2778 $rOpts->{'default-tabsize'} = 20;
2782 $rOpts->{'default-tabsize'} = 8;
2785 # Define $tabsize, the number of spaces per tab for use in
2786 # guessing the indentation of source lines with leading tabs.
2787 # Assume same as for this run if tabs are used , otherwise assume
2788 # a default value, typically 8
2790 $rOpts->{'entab-leading-whitespace'}
2791 ? $rOpts->{'entab-leading-whitespace'}
2792 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
2793 : $rOpts->{'default-tabsize'};
2797 sub find_file_upwards {
2798 my ( $search_dir, $search_file ) = @_;
2800 $search_dir =~ s{/+$}{};
2801 $search_file =~ s{^/+}{};
2804 my $try_path = "$search_dir/$search_file";
2805 if ( -f $try_path ) {
2808 elsif ( $search_dir eq '/' ) {
2812 $search_dir = dirname($search_dir);
2816 # This return is for Perl-Critic.
2817 # We shouldn't get out of the while loop without a return
2821 sub expand_command_abbreviations {
2823 # go through @ARGV and expand any abbreviations
2825 my ( $rexpansion, $rraw_options, $config_file ) = @_;
2827 # set a pass limit to prevent an infinite loop;
2828 # 10 should be plenty, but it may be increased to allow deeply
2829 # nested expansions.
2830 my $max_passes = 10;
2833 # keep looping until all expansions have been converted into actual
2835 foreach my $pass_count ( 0 .. $max_passes ) {
2837 my $abbrev_count = 0;
2839 # loop over each item in @ARGV..
2840 foreach my $word (@ARGV) {
2842 # convert any leading 'no-' to just 'no'
2843 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
2845 # if it is a dash flag (instead of a file name)..
2846 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
2851 # save the raw input for debug output in case of circular refs
2852 if ( $pass_count == 0 ) {
2853 push( @{$rraw_options}, $word );
2856 # recombine abbreviation and flag, if necessary,
2857 # to allow abbreviations with arguments such as '-vt=1'
2858 if ( $rexpansion->{ $abr . $flags } ) {
2859 $abr = $abr . $flags;
2863 # if we see this dash item in the expansion hash..
2864 if ( $rexpansion->{$abr} ) {
2867 # stuff all of the words that it expands to into the
2868 # new arg list for the next pass
2869 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
2870 next unless $abbrev; # for safety; shouldn't happen
2871 push( @new_argv, '--' . $abbrev . $flags );
2875 # not in expansion hash, must be actual long name
2877 push( @new_argv, $word );
2881 # not a dash item, so just save it for the next pass
2883 push( @new_argv, $word );
2885 } # end of this pass
2887 # update parameter list @ARGV to the new one
2889 last unless ( $abbrev_count > 0 );
2891 # make sure we are not in an infinite loop
2892 if ( $pass_count == $max_passes ) {
2895 I'm tired. We seem to be in an infinite loop trying to expand aliases.
2896 Here are the raw options;
2899 my $num = @new_argv;
2902 After $max_passes passes here is ARGV
2908 After $max_passes passes ARGV has $num entries
2914 Please check your configuration file $config_file for circular-references.
2915 To deactivate it, use -npro.
2920 Program bug - circular-references in the %expansion hash, probably due to
2921 a recent program change.
2924 } # end of check for circular references
2925 } # end of loop over all passes
2929 # Debug routine -- this will dump the expansion hash
2930 sub dump_short_names {
2931 my $rexpansion = shift;
2933 List of short names. This list shows how all abbreviations are
2934 translated into other abbreviations and, eventually, into long names.
2935 New abbreviations may be defined in a .perltidyrc file.
2936 For a list of all long names, use perltidy --dump-long-names (-dln).
2937 --------------------------------------------------------------------------
2939 foreach my $abbrev ( sort keys %$rexpansion ) {
2940 my @list = @{ $rexpansion->{$abbrev} };
2941 print STDOUT "$abbrev --> @list\n";
2946 sub check_vms_filename {
2948 # given a valid filename (the perltidy input file)
2949 # create a modified filename and separator character
2952 # Contributed by Michael Cartmell
2954 my $filename = shift;
2955 my ( $base, $path ) = fileparse($filename);
2957 # remove explicit ; version
2958 $base =~ s/;-?\d*$//
2960 # remove explicit . version ie two dots in filename NB ^ escapes a dot
2961 or $base =~ s/( # begin capture $1
2962 (?:^|[^^])\. # match a dot not preceded by a caret
2963 (?: # followed by nothing
2965 .*[^^] # anything ending in a non caret
2968 \.-?\d*$ # match . version number
2971 # normalise filename, if there are no unescaped dots then append one
2972 $base .= '.' unless $base =~ /(?:^|[^^])\./;
2974 # if we don't already have an extension then we just append the extension
2975 my $separator = ( $base =~ /\.$/ ) ? "" : "_";
2976 return ( $path . $base, $separator );
2981 # TODO: are these more standard names?
2982 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
2984 # Returns a string that determines what MS OS we are on.
2985 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
2986 # Returns blank string if not an MS system.
2987 # Original code contributed by: Yves Orton
2988 # We need to know this to decide where to look for config files
2990 my $rpending_complaint = shift;
2992 return $os unless $^O =~ /win32|dos/i; # is it a MS box?
2994 # Systems built from Perl source may not have Win32.pm
2995 # But probably have Win32::GetOSVersion() anyway so the
2996 # following line is not 'required':
2997 # return $os unless eval('require Win32');
2999 # Use the standard API call to determine the version
3000 my ( $undef, $major, $minor, $build, $id );
3001 eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
3004 # NAME ID MAJOR MINOR
3005 # Windows NT 4 2 4 0
3006 # Windows 2000 2 5 0
3008 # Windows Server 2003 2 5 2
3010 return "win32s" unless $id; # If id==0 then its a win32s box.
3011 $os = { # Magic numbers from MSDN
3012 # documentation of GetOSVersion
3019 0 => "2000", # or NT 4, see below
3026 # If $os is undefined, the above code is out of date. Suggested updates
3028 unless ( defined $os ) {
3031 # Deactivated this message 20180322 because it was needlessly
3032 # causing some test scripts to fail. Need help from someone
3033 # with expertise in Windows to decide what is possible with windows.
3034 ${$rpending_complaint} .= <<EOS if (0);
3035 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
3036 We won't be able to look for a system-wide config file.
3040 # Unfortunately the logic used for the various versions isn't so clever..
3041 # so we have to handle an outside case.
3042 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
3047 ( $^O !~ /win32|dos/i )
3050 && ( $^O ne 'MacOS' );
3053 sub look_for_Windows {
3055 # determine Windows sub-type and location of
3056 # system-wide configuration files
3057 my $rpending_complaint = shift;
3058 my $is_Windows = ( $^O =~ /win32|dos/i );
3060 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
3061 return ( $is_Windows, $Windows_type );
3064 sub find_config_file {
3066 # look for a .perltidyrc configuration file
3067 # For Windows also look for a file named perltidy.ini
3068 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
3069 $rpending_complaint ) = @_;
3071 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
3073 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
3076 ${$rconfig_file_chatter} .= " $^O\n";
3079 # sub to check file existence and record all tests
3080 my $exists_config_file = sub {
3081 my $config_file = shift;
3082 return 0 unless $config_file;
3083 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
3084 return -f $config_file;
3087 # Sub to search upward for config file
3088 my $resolve_config_file = sub {
3090 # resolve <dir>/.../<file>, meaning look upwards from directory
3091 my $config_file = shift;
3093 if ( my ( $start_dir, $search_file ) =
3094 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3096 ${$rconfig_file_chatter} .=
3097 "# Searching Upward: $config_file\n";
3098 $start_dir = '.' if !$start_dir;
3099 $start_dir = Cwd::realpath($start_dir);
3100 if ( my $found_file =
3101 find_file_upwards( $start_dir, $search_file ) )
3103 $config_file = $found_file;
3104 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
3108 return $config_file;
3113 # look in current directory first
3114 $config_file = ".perltidyrc";
3115 return $config_file if $exists_config_file->($config_file);
3117 $config_file = "perltidy.ini";
3118 return $config_file if $exists_config_file->($config_file);
3121 # Default environment vars.
3122 my @envs = qw(PERLTIDY HOME);
3124 # Check the NT/2k/XP locations, first a local machine def, then a
3126 push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
3128 # Now go through the environment ...
3129 foreach my $var (@envs) {
3130 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
3131 if ( defined( $ENV{$var} ) ) {
3132 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
3134 # test ENV{ PERLTIDY } as file:
3135 if ( $var eq 'PERLTIDY' ) {
3136 $config_file = "$ENV{$var}";
3137 $config_file = $resolve_config_file->($config_file);
3138 return $config_file if $exists_config_file->($config_file);
3141 # test ENV as directory:
3142 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
3143 $config_file = $resolve_config_file->($config_file);
3144 return $config_file if $exists_config_file->($config_file);
3147 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
3148 $config_file = $resolve_config_file->($config_file);
3149 return $config_file if $exists_config_file->($config_file);
3153 ${$rconfig_file_chatter} .= "\n";
3157 # then look for a system-wide definition
3158 # where to look varies with OS
3161 if ($Windows_type) {
3162 my ( $os, $system, $allusers ) =
3163 Win_Config_Locs( $rpending_complaint, $Windows_type );
3165 # Check All Users directory, if there is one.
3166 # i.e. C:\Documents and Settings\User\perltidy.ini
3169 $config_file = catfile( $allusers, ".perltidyrc" );
3170 return $config_file if $exists_config_file->($config_file);
3172 $config_file = catfile( $allusers, "perltidy.ini" );
3173 return $config_file if $exists_config_file->($config_file);
3176 # Check system directory.
3177 # retain old code in case someone has been able to create
3178 # a file with a leading period.
3179 $config_file = catfile( $system, ".perltidyrc" );
3180 return $config_file if $exists_config_file->($config_file);
3182 $config_file = catfile( $system, "perltidy.ini" );
3183 return $config_file if $exists_config_file->($config_file);
3187 # Place to add customization code for other systems
3188 elsif ( $^O eq 'OS2' ) {
3190 elsif ( $^O eq 'MacOS' ) {
3192 elsif ( $^O eq 'VMS' ) {
3195 # Assume some kind of Unix
3198 $config_file = "/usr/local/etc/perltidyrc";
3199 return $config_file if $exists_config_file->($config_file);
3201 $config_file = "/etc/perltidyrc";
3202 return $config_file if $exists_config_file->($config_file);
3205 # Couldn't find a config file
3209 sub Win_Config_Locs {
3211 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
3212 # or undef if its not a win32 OS. In list context returns OS, System
3213 # Directory, and All Users Directory. All Users will be empty on a
3214 # 9x/Me box. Contributed by: Yves Orton.
3217 # my $rpending_complaint = shift;
3218 # my $os = (@_) ? shift : Win_OS_Type();
3220 my ( $rpending_complaint, $os ) = @_;
3221 if ( !$os ) { $os = Win_OS_Type(); }
3228 if ( $os =~ /9[58]|Me/ ) {
3229 $system = "C:/Windows";
3231 elsif ( $os =~ /NT|XP|200?/ ) {
3232 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
3235 ? "C:/WinNT/profiles/All Users/"
3236 : "C:/Documents and Settings/All Users/";
3240 # This currently would only happen on a win32s computer. I don't have
3241 # one to test, so I am unsure how to proceed. Suggestions welcome!
3242 ${$rpending_complaint} .=
3243 "I dont know a sensible place to look for config files on an $os system.\n";
3246 return wantarray ? ( $os, $system, $allusers ) : $os;
3249 sub dump_config_file {
3250 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
3251 print STDOUT "$$rconfig_file_chatter";
3253 print STDOUT "# Dump of file: '$config_file'\n";
3254 while ( my $line = $fh->getline() ) { print STDOUT $line }
3255 eval { $fh->close() };
3258 print STDOUT "# ...no config file found\n";
3263 sub read_config_file {
3265 my ( $fh, $config_file, $rexpansion ) = @_;
3266 my @config_list = ();
3268 # file is bad if non-empty $death_message is returned
3269 my $death_message = "";
3273 my $opening_brace_line;
3274 while ( my $line = $fh->getline() ) {
3277 ( $line, $death_message ) =
3278 strip_comment( $line, $config_file, $line_no );
3279 last if ($death_message);
3281 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
3286 # Look for complete or partial abbreviation definition of the form
3287 # name { body } or name { or name { body
3288 # See rules in perltidy's perldoc page
3289 # Section: Other Controls - Creating a new abbreviation
3290 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
3291 my $oldname = $name;
3292 ( $name, $body ) = ( $2, $3 );
3294 # Cannot start new abbreviation unless old abbreviation is complete
3295 last if ($opening_brace_line);
3297 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
3299 # handle a new alias definition
3300 if ( ${$rexpansion}{$name} ) {
3302 my @names = sort keys %$rexpansion;
3304 "Here is a list of all installed aliases\n(@names)\n"
3305 . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
3308 ${$rexpansion}{$name} = [];
3311 # leading opening braces not allowed
3312 elsif ( $line =~ /^{/ ) {
3313 $opening_brace_line = undef;
3315 "Unexpected '{' at line $line_no in config file '$config_file'\n";
3319 # Look for abbreviation closing: body } or }
3320 elsif ( $line =~ /^(.*)?\}$/ ) {
3322 if ($opening_brace_line) {
3323 $opening_brace_line = undef;
3327 "Unexpected '}' at line $line_no in config file '$config_file'\n";
3332 # Now store any parameters
3335 my ( $rbody_parts, $msg ) = parse_args($body);
3337 $death_message = <<EOM;
3338 Error reading file '$config_file' at line number $line_no.
3340 Please fix this line or use -npro to avoid reading this file
3347 # remove leading dashes if this is an alias
3348 foreach ( @{$rbody_parts} ) { s/^\-+//; }
3349 push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
3352 push( @config_list, @{$rbody_parts} );
3357 if ($opening_brace_line) {
3359 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
3361 eval { $fh->close() };
3362 return ( \@config_list, $death_message );
3367 # Strip any comment from a command line
3368 my ( $instr, $config_file, $line_no ) = @_;
3371 # check for full-line comment
3372 if ( $instr =~ /^\s*#/ ) {
3373 return ( "", $msg );
3376 # nothing to do if no comments
3377 if ( $instr !~ /#/ ) {
3378 return ( $instr, $msg );
3381 # handle case of no quotes
3382 elsif ( $instr !~ /['"]/ ) {
3384 # We now require a space before the # of a side comment
3385 # this allows something like:
3387 # Otherwise, it would have to be quoted:
3389 $instr =~ s/\s+\#.*$//;
3390 return ( $instr, $msg );
3393 # handle comments and quotes
3395 my $quote_char = "";
3398 # looking for ending quote character
3400 if ( $instr =~ /\G($quote_char)/gc ) {
3404 elsif ( $instr =~ /\G(.)/gc ) {
3408 # error..we reached the end without seeing the ending quote char
3411 Error reading file $config_file at line number $line_no.
3412 Did not see ending quote character <$quote_char> in this text:
3414 Please fix this line or use -npro to avoid reading this file
3420 # accumulating characters and looking for start of a quoted string
3422 if ( $instr =~ /\G([\"\'])/gc ) {
3427 # Note: not yet enforcing the space-before-hash rule for side
3428 # comments if the parameter is quoted.
3429 elsif ( $instr =~ /\G#/gc ) {
3432 elsif ( $instr =~ /\G(.)/gc ) {
3440 return ( $outstr, $msg );
3445 # Parse a command string containing multiple string with possible
3446 # quotes, into individual commands. It might look like this, for example:
3448 # -wba=" + - " -some-thing -wbb='. && ||'
3450 # There is no need, at present, to handle escaped quote characters.
3451 # (They are not perltidy tokens, so needn't be in strings).
3454 my @body_parts = ();
3455 my $quote_char = "";
3460 # looking for ending quote character
3462 if ( $body =~ /\G($quote_char)/gc ) {
3465 elsif ( $body =~ /\G(.)/gc ) {
3469 # error..we reached the end without seeing the ending quote char
3471 if ( length($part) ) { push @body_parts, $part; }
3473 Did not see ending quote character <$quote_char> in this text:
3480 # accumulating characters and looking for start of a quoted string
3482 if ( $body =~ /\G([\"\'])/gc ) {
3485 elsif ( $body =~ /\G(\s+)/gc ) {
3486 if ( length($part) ) { push @body_parts, $part; }
3489 elsif ( $body =~ /\G(.)/gc ) {
3493 if ( length($part) ) { push @body_parts, $part; }
3498 return ( \@body_parts, $msg );
3501 sub dump_long_names {
3505 # Command line long names (passed to GetOptions)
3506 #---------------------------------------------------------------
3507 # here is a summary of the Getopt codes:
3508 # <none> does not take an argument
3509 # =s takes a mandatory string
3510 # :s takes an optional string
3511 # =i takes a mandatory integer
3512 # :i takes an optional integer
3513 # ! does not take an argument and may be negated
3514 # i.e., -foo and -nofoo are allowed
3515 # a double dash signals the end of the options list
3517 #---------------------------------------------------------------
3520 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
3526 print STDOUT "Default command line options:\n";
3527 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
3531 sub readable_options {
3533 # return options for this run as a string which could be
3534 # put in a perltidyrc file
3535 my ( $rOpts, $roption_string ) = @_;
3537 my $rGetopt_flags = \%Getopt_flags;
3538 my $readable_options = "# Final parameter set for this run.\n";
3539 $readable_options .=
3540 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
3541 foreach my $opt ( @{$roption_string} ) {
3543 if ( $opt =~ /(.*)(!|=.*)$/ ) {
3547 if ( defined( $rOpts->{$opt} ) ) {
3548 $rGetopt_flags->{$opt} = $flag;
3551 foreach my $key ( sort keys %{$rOpts} ) {
3552 my $flag = $rGetopt_flags->{$key};
3553 my $value = $rOpts->{$key};
3557 if ( $flag =~ /^=/ ) {
3558 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
3559 $suffix = "=" . $value;
3561 elsif ( $flag =~ /^!/ ) {
3562 $prefix .= "no" unless ($value);
3567 $readable_options .=
3568 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
3571 $readable_options .= $prefix . $key . $suffix . "\n";
3573 return $readable_options;
3577 print STDOUT <<"EOM";
3578 This is perltidy, v$VERSION
3580 Copyright 2000-2019, Steve Hancock
3582 Perltidy is free software and may be copied under the terms of the GNU
3583 General Public License, which is included in the distribution files.
3585 Complete documentation for perltidy can be found using 'man perltidy'
3586 or on the internet at http://perltidy.sourceforge.net.
3594 This is perltidy version $VERSION, a perl script indenter. Usage:
3596 perltidy [ options ] file1 file2 file3 ...
3597 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
3598 perltidy [ options ] file1 -o outfile
3599 perltidy [ options ] file1 -st >outfile
3600 perltidy [ options ] <infile >outfile
3602 Options have short and long forms. Short forms are shown; see
3603 man pages for long forms. Note: '=s' indicates a required string,
3604 and '=n' indicates a required integer.
3608 -o=file name of the output file (only if single input file)
3609 -oext=s change output extension from 'tdy' to s
3610 -opath=path change path to be 'path' for output files
3611 -b backup original to .bak and modify file in-place
3612 -bext=s change default backup extension from 'bak' to s
3613 -q deactivate error messages (for running under editor)
3614 -w include non-critical warning messages in the .ERR error output
3615 -syn run perl -c to check syntax (default under unix systems)
3616 -log save .LOG file, which has useful diagnostics
3617 -f force perltidy to read a binary file
3618 -g like -log but writes more detailed .LOG file, for debugging scripts
3619 -opt write the set of options actually used to a .LOG file
3620 -npro ignore .perltidyrc configuration command file
3621 -pro=file read configuration commands from file instead of .perltidyrc
3622 -st send output to standard output, STDOUT
3623 -se send all error output to standard error output, STDERR
3624 -v display version number to standard output and quit
3627 -i=n use n columns per indentation level (default n=4)
3628 -t tabs: use one tab character per indentation level, not recommeded
3629 -nt no tabs: use n spaces per indentation level (default)
3630 -et=n entab leading whitespace n spaces per tab; not recommended
3631 -io "indent only": just do indentation, no other formatting.
3632 -sil=n set starting indentation level to n; use if auto detection fails
3633 -ole=s specify output line ending (s=dos or win, mac, unix)
3634 -ple keep output line endings same as input (input must be filename)
3637 -fws freeze whitespace; this disables all whitespace changes
3638 and disables the following switches:
3639 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
3640 -bbt same as -bt but for code block braces; same as -bt if not given
3641 -bbvt block braces vertically tight; use with -bl or -bli
3642 -bbvtl=s make -bbvt to apply to selected list of block types
3643 -pt=n paren tightness (n=0, 1 or 2)
3644 -sbt=n square bracket tightness (n=0, 1, or 2)
3645 -bvt=n brace vertical tightness,
3646 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
3647 -pvt=n paren vertical tightness (see -bvt for n)
3648 -sbvt=n square bracket vertical tightness (see -bvt for n)
3649 -bvtc=n closing brace vertical tightness:
3650 n=(0=open, 1=sometimes close, 2=always close)
3651 -pvtc=n closing paren vertical tightness, see -bvtc for n.
3652 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
3653 -ci=n sets continuation indentation=n, default is n=2 spaces
3654 -lp line up parentheses, brackets, and non-BLOCK braces
3655 -sfs add space before semicolon in for( ; ; )
3656 -aws allow perltidy to add whitespace (default)
3657 -dws delete all old non-essential whitespace
3658 -icb indent closing brace of a code block
3659 -cti=n closing indentation of paren, square bracket, or non-block brace:
3660 n=0 none, =1 align with opening, =2 one full indentation level
3661 -icp equivalent to -cti=2
3662 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
3663 -wrs=s want space right of tokens in string;
3664 -sts put space before terminal semicolon of a statement
3665 -sak=s put space between keywords given in s and '(';
3666 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
3669 -fnl freeze newlines; this disables all line break changes
3670 and disables the following switches:
3671 -anl add newlines; ok to introduce new line breaks
3672 -bbs add blank line before subs and packages
3673 -bbc add blank line before block comments
3674 -bbb add blank line between major blocks
3675 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
3676 -mbl=n maximum consecutive blank lines to output (default=1)
3677 -ce cuddled else; use this style: '} else {'
3678 -cb cuddled blocks (other than 'if-elsif-else')
3679 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
3680 -dnl delete old newlines (default)
3681 -l=n maximum line length; default n=80
3682 -bl opening brace on new line
3683 -sbl opening sub brace on new line. value of -bl is used if not given.
3684 -bli opening brace on new line and indented
3685 -bar opening brace always on right, even for long clauses
3686 -vt=n vertical tightness (requires -lp); n controls break after opening
3687 token: 0=never 1=no break if next line balanced 2=no break
3688 -vtc=n vertical tightness of closing container; n controls if closing
3689 token starts new line: 0=always 1=not unless list 1=never
3690 -wba=s want break after tokens in string; i.e. wba=': .'
3691 -wbb=s want break before tokens in string
3692 -wn weld nested: combines opening and closing tokens when both are adjacent
3694 Following Old Breakpoints
3695 -kis keep interior semicolons. Allows multiple statements per line.
3696 -boc break at old comma breaks: turns off all automatic list formatting
3697 -bol break at old logical breakpoints: or, and, ||, && (default)
3698 -bom break at old method call breakpoints: ->
3699 -bok break at old list keyword breakpoints such as map, sort (default)
3700 -bot break at old conditional (ternary ?:) operator breakpoints (default)
3701 -boa break at old attribute breakpoints
3702 -cab=n break at commas after a comma-arrow (=>):
3703 n=0 break at all commas after =>
3704 n=1 stable: break unless this breaks an existing one-line container
3705 n=2 break only if a one-line container cannot be formed
3706 n=3 do not treat commas after => specially at all
3709 -ibc indent block comments (default)
3710 -isbc indent spaced block comments; may indent unless no leading space
3711 -msc=n minimum desired spaces to side comment, default 4
3712 -fpsc=n fix position for side comments; default 0;
3713 -csc add or update closing side comments after closing BLOCK brace
3714 -dcsc delete closing side comments created by a -csc command
3715 -cscp=s change closing side comment prefix to be other than '## end'
3716 -cscl=s change closing side comment to apply to selected list of blocks
3717 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
3718 -csct=n maximum number of columns of appended text, default n=20
3719 -cscw causes warning if old side comment is overwritten with -csc
3721 -sbc use 'static block comments' identified by leading '##' (default)
3722 -sbcp=s change static block comment identifier to be other than '##'
3723 -osbc outdent static block comments
3725 -ssc use 'static side comments' identified by leading '##' (default)
3726 -sscp=s change static side comment identifier to be other than '##'
3728 Delete selected text
3729 -dac delete all comments AND pod
3730 -dbc delete block comments
3731 -dsc delete side comments
3734 Send selected text to a '.TEE' file
3735 -tac tee all comments AND pod
3736 -tbc tee block comments
3737 -tsc tee side comments
3741 -olq outdent long quoted strings (default)
3742 -olc outdent a long block comment line
3743 -ola outdent statement labels
3744 -okw outdent control keywords (redo, next, last, goto, return)
3745 -okwl=s specify alternative keywords for -okw command
3748 -mft=n maximum fields per table; default n=40
3749 -x do not format lines before hash-bang line (i.e., for VMS)
3750 -asc allows perltidy to add a ';' when missing (default)
3751 -dsm allows perltidy to delete an unnecessary ';' (default)
3753 Combinations of other parameters
3754 -gnu attempt to follow GNU Coding Standards as applied to perl
3755 -mangle remove as many newlines as possible (but keep comments and pods)
3756 -extrude insert as many newlines as possible
3758 Dump and die, debugging
3759 -dop dump options used in this run to standard output and quit
3760 -ddf dump default options to standard output and quit
3761 -dsn dump all option short names to standard output and quit
3762 -dln dump option long names to standard output and quit
3763 -dpro dump whatever configuration file is in effect to standard output
3764 -dtt dump all token types to standard output and quit
3767 -html write an html file (see 'man perl2web' for many options)
3768 Note: when -html is used, no indentation or formatting are done.
3769 Hint: try perltidy -html -css=mystyle.css filename.pl
3770 and edit mystyle.css to change the appearance of filename.html.
3771 -nnn gives line numbers
3772 -pre only writes out <pre>..</pre> code section
3773 -toc places a table of contents to subs at the top (default)
3774 -pod passes pod text through pod2html (default)
3775 -frm write html as a frame (3 files)
3776 -text=s extra extension for table of contents if -frm, default='toc'
3777 -sext=s extra extension for file content if -frm, default='src'
3779 A prefix of "n" negates short form toggle switches, and a prefix of "no"
3780 negates the long forms. For example, -nasc means don't add missing
3783 If you are unable to see this entire text, try "perltidy -h | more"
3784 For more detailed information, and additional options, try "man perltidy",
3785 or go to the perltidy home page at http://perltidy.sourceforge.net
3791 sub process_this_file {
3793 my ( $tokenizer, $formatter ) = @_;
3795 while ( my $line = $tokenizer->get_line() ) {
3796 $formatter->write_line($line);
3798 my $severe_error = $tokenizer->report_tokenization_errors();
3799 eval { $formatter->finish_formatting($severe_error) };
3806 # Use 'perl -c' to make sure that we did not create bad syntax
3807 # This is a very good independent check for programming errors
3809 # Given names of the input and output files, ($istream, $ostream),
3810 # we do the following:
3811 # - check syntax of the input file
3812 # - if bad, all done (could be an incomplete code snippet)
3813 # - if infile syntax ok, then check syntax of the output file;
3814 # - if outfile syntax bad, issue warning; this implies a code bug!
3815 # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
3817 my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
3818 my $infile_syntax_ok = 0;
3819 my $line_of_dashes = '-' x 42 . "\n";
3821 my $flags = $rOpts->{'perl-syntax-check-flags'};
3823 # be sure we invoke perl with -c
3824 # note: perl will accept repeated flags like '-c -c'. It is safest
3825 # to append another -c than try to find an interior bundled c, as
3826 # in -Tc, because such a 'c' might be in a quoted string, for example.
3827 if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
3829 # be sure we invoke perl with -x if requested
3830 # same comments about repeated parameters applies
3831 if ( $rOpts->{'look-for-hash-bang'} ) {
3832 if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
3835 # this shouldn't happen unless a temporary file couldn't be made
3836 if ( $istream eq '-' ) {
3837 $logger_object->write_logfile_entry(
3838 "Cannot run perl -c on STDIN and STDOUT\n");
3839 return $infile_syntax_ok;
3842 $logger_object->write_logfile_entry(
3843 "checking input file syntax with perl $flags\n");
3845 # Not all operating systems/shells support redirection of the standard
3847 my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
3849 my ( $istream_filename, $perl_output ) =
3850 do_syntax_check( $istream, $flags, $error_redirection );
3851 $logger_object->write_logfile_entry(
3852 "Input stream passed to Perl as file $istream_filename\n");
3853 $logger_object->write_logfile_entry($line_of_dashes);
3854 $logger_object->write_logfile_entry("$perl_output\n");
3856 if ( $perl_output =~ /syntax\s*OK/ ) {
3857 $infile_syntax_ok = 1;
3858 $logger_object->write_logfile_entry($line_of_dashes);
3859 $logger_object->write_logfile_entry(
3860 "checking output file syntax with perl $flags ...\n");
3861 my ( $ostream_filename, $perl_output ) =
3862 do_syntax_check( $ostream, $flags, $error_redirection );
3863 $logger_object->write_logfile_entry(
3864 "Output stream passed to Perl as file $ostream_filename\n");
3865 $logger_object->write_logfile_entry($line_of_dashes);
3866 $logger_object->write_logfile_entry("$perl_output\n");
3868 unless ( $perl_output =~ /syntax\s*OK/ ) {
3869 $logger_object->write_logfile_entry($line_of_dashes);
3870 $logger_object->warning(
3871 "The output file has a syntax error when tested with perl $flags $ostream !\n"
3873 $logger_object->warning(
3874 "This implies an error in perltidy; the file $ostream is bad\n"
3876 $logger_object->report_definite_bug();
3878 # the perl version number will be helpful for diagnosing the problem
3879 $logger_object->write_logfile_entry( $^V . "\n" );
3884 # Only warn of perl -c syntax errors. Other messages,
3885 # such as missing modules, are too common. They can be
3886 # seen by running with perltidy -w
3887 $logger_object->complain("A syntax check using perl $flags\n");
3888 $logger_object->complain(
3889 "for the output in file $istream_filename gives:\n");
3890 $logger_object->complain($line_of_dashes);
3891 $logger_object->complain("$perl_output\n");
3892 $logger_object->complain($line_of_dashes);
3893 $infile_syntax_ok = -1;
3894 $logger_object->write_logfile_entry($line_of_dashes);
3895 $logger_object->write_logfile_entry(
3896 "The output file will not be checked because of input file problems\n"
3899 return $infile_syntax_ok;
3902 sub do_syntax_check {
3904 # This should not be called; the syntax check is deactivated
3905 Die("Unexpected call for syntax check-shouldn't happen\n");
3910 sub do_syntax_check {
3911 my ( $stream, $flags, $error_redirection ) = @_;
3913 ############################################################
3914 # This code is not reachable because syntax check is deactivated,
3915 # but it is retained for reference.
3916 ############################################################
3918 # We need a named input file for executing perl
3919 my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
3921 # TODO: Need to add name of file to log somewhere
3922 # otherwise Perl output is hard to read
3923 if ( !$stream_filename ) { return $stream_filename, "" }
3925 # We have to quote the filename in case it has unusual characters
3926 # or spaces. Example: this filename #CM11.pm# gives trouble.
3927 my $quoted_stream_filename = '"' . $stream_filename . '"';
3929 # Under VMS something like -T will become -t (and an error) so we
3930 # will put quotes around the flags. Double quotes seem to work on
3931 # Unix/Windows/VMS, but this may not work on all systems. (Single
3932 # quotes do not work under Windows). It could become necessary to
3933 # put double quotes around each flag, such as: -"c" -"T"
3934 # We may eventually need some system-dependent coding here.
3935 $flags = '"' . $flags . '"';
3937 # now wish for luck...
3938 my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/;
3941 unlink $stream_filename
3942 or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n");
3944 return $stream_filename, $msg;