2 ###########################################################-
4 # perltidy - a perl script indenter and formatter
6 # Copyright (c) 2000-2018 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 = '20181120';
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 # Quietly return undef 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
257 #BEGIN { eval "require File::Spec"; $missing_file_spec = $@; }
259 eval { require File::Spec };
260 $missing_file_spec = $@;
263 # use File::Spec if we can
264 unless ($missing_file_spec) {
265 return File::Spec->catfile(@parts);
268 # Perl 5.004 systems may not have File::Spec so we'll make
269 # a simple try. We assume File::Basename is available.
270 # return undef if not successful.
271 my $name = pop @parts;
272 my $path = join '/', @parts;
273 my $test_file = $path . $name;
274 my ( $test_name, $test_path ) = fileparse($test_file);
275 return $test_file if ( $test_name eq $name );
276 return if ( $^O eq 'VMS' );
278 # this should work at least for Windows and Unix:
279 $test_file = $path . '/' . $name;
280 ( $test_name, $test_path ) = fileparse($test_file);
281 return $test_file if ( $test_name eq $name );
285 # Here is a map of the flow of data from the input source to the output
288 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
289 # input groups output
290 # lines tokens lines of lines lines
293 # The names correspond to the package names responsible for the unit processes.
295 # The overall process is controlled by the "main" package.
297 # LineSource is the stream of input lines
299 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
300 # if necessary. A token is any section of the input line which should be
301 # manipulated as a single entity during formatting. For example, a single
302 # ',' character is a token, and so is an entire side comment. It handles
303 # the complexities of Perl syntax, such as distinguishing between '<<' as
304 # a shift operator and as a here-document, or distinguishing between '/'
305 # as a divide symbol and as a pattern delimiter.
307 # Formatter inserts and deletes whitespace between tokens, and breaks
308 # sequences of tokens at appropriate points as output lines. It bases its
309 # decisions on the default rules as modified by any command-line options.
311 # VerticalAligner collects groups of lines together and tries to line up
312 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
314 # FileWriter simply writes lines to the output stream.
316 # The Logger package, not shown, records significant events and warning
317 # messages. It writes a .LOG file, which may be saved with a
318 # '-log' or a '-g' flag.
326 destination => undef,
333 dump_options => undef,
334 dump_options_type => undef,
335 dump_getopt_flags => undef,
336 dump_options_category => undef,
337 dump_options_range => undef,
338 dump_abbreviations => undef,
343 # don't overwrite callers ARGV
345 local *STDERR = *STDERR;
347 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
349 my @good_keys = sort keys %defaults;
350 @bad_keys = sort @bad_keys;
352 ------------------------------------------------------------------------
353 Unknown perltidy parameter : (@bad_keys)
354 perltidy only understands : (@good_keys)
355 ------------------------------------------------------------------------
360 my $get_hash_ref = sub {
362 my $hash_ref = $input_hash{$key};
363 if ( defined($hash_ref) ) {
364 unless ( ref($hash_ref) eq 'HASH' ) {
365 my $what = ref($hash_ref);
367 $what ? "but is ref to $what" : "but is not a reference";
369 ------------------------------------------------------------------------
370 error in call to perltidy:
371 -$key must be reference to HASH $but_is
372 ------------------------------------------------------------------------
379 %input_hash = ( %defaults, %input_hash );
380 my $argv = $input_hash{'argv'};
381 my $destination_stream = $input_hash{'destination'};
382 my $errorfile_stream = $input_hash{'errorfile'};
383 my $logfile_stream = $input_hash{'logfile'};
384 my $perltidyrc_stream = $input_hash{'perltidyrc'};
385 my $source_stream = $input_hash{'source'};
386 my $stderr_stream = $input_hash{'stderr'};
387 my $user_formatter = $input_hash{'formatter'};
388 my $prefilter = $input_hash{'prefilter'};
389 my $postfilter = $input_hash{'postfilter'};
391 if ($stderr_stream) {
392 ( $fh_stderr, my $stderr_file ) =
393 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
396 ------------------------------------------------------------------------
397 Unable to redirect STDERR to $stderr_stream
398 Please check value of -stderr in call to perltidy
399 ------------------------------------------------------------------------
404 $fh_stderr = *STDERR;
407 sub Warn { my $msg = shift; $fh_stderr->print($msg); return }
411 if ($flag) { goto ERROR_EXIT }
412 else { goto NORMAL_EXIT }
413 croak "unexpectd return to Exit";
420 croak "unexpected return to Die";
423 # extract various dump parameters
424 my $dump_options_type = $input_hash{'dump_options_type'};
425 my $dump_options = $get_hash_ref->('dump_options');
426 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
427 my $dump_options_category = $get_hash_ref->('dump_options_category');
428 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
429 my $dump_options_range = $get_hash_ref->('dump_options_range');
431 # validate dump_options_type
432 if ( defined($dump_options) ) {
433 unless ( defined($dump_options_type) ) {
434 $dump_options_type = 'perltidyrc';
436 unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
438 ------------------------------------------------------------------------
439 Please check value of -dump_options_type in call to perltidy;
440 saw: '$dump_options_type'
441 expecting: 'perltidyrc' or 'full'
442 ------------------------------------------------------------------------
448 $dump_options_type = "";
451 if ($user_formatter) {
453 # if the user defines a formatter, there is no output stream,
454 # but we need a null stream to keep coding simple
455 $destination_stream = Perl::Tidy::DevNull->new();
458 # see if ARGV is overridden
459 if ( defined($argv) ) {
461 my $rargv = ref $argv;
462 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
466 if ( $rargv eq 'ARRAY' ) {
471 ------------------------------------------------------------------------
472 Please check value of -argv in call to perltidy;
473 it must be a string or ref to ARRAY but is: $rargv
474 ------------------------------------------------------------------------
481 my ( $rargv, $msg ) = parse_args($argv);
484 Error parsing this string passed to to perltidy with 'argv':
492 my $rpending_complaint;
493 ${$rpending_complaint} = "";
494 my $rpending_logfile_message;
495 ${$rpending_logfile_message} = "";
497 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
499 # VMS file names are restricted to a 40.40 format, so we append _tdy
500 # instead of .tdy, etc. (but see also sub check_vms_filename)
503 if ( $^O eq 'VMS' ) {
509 $dot_pattern = '\.'; # must escape for use in regex
512 #---------------------------------------------------------------
513 # get command line options
514 #---------------------------------------------------------------
515 my ( $rOpts, $config_file, $rraw_options, $roption_string,
516 $rexpansion, $roption_category, $roption_range )
517 = process_command_line(
518 $perltidyrc_stream, $is_Windows, $Windows_type,
519 $rpending_complaint, $dump_options_type,
522 my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
524 ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
526 #---------------------------------------------------------------
527 # Handle requests to dump information
528 #---------------------------------------------------------------
530 # return or exit immediately after all dumps
533 # Getopt parameters and their flags
534 if ( defined($dump_getopt_flags) ) {
536 foreach my $op ( @{$roption_string} ) {
545 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
549 $dump_getopt_flags->{$opt} = $flag;
553 if ( defined($dump_options_category) ) {
555 %{$dump_options_category} = %{$roption_category};
558 if ( defined($dump_options_range) ) {
560 %{$dump_options_range} = %{$roption_range};
563 if ( defined($dump_abbreviations) ) {
565 %{$dump_abbreviations} = %{$rexpansion};
568 if ( defined($dump_options) ) {
570 %{$dump_options} = %{$rOpts};
573 Exit(0) if ($quit_now);
575 # make printable string of options for this run as possible diagnostic
576 my $readable_options = readable_options( $rOpts, $roption_string );
578 # dump from command line
579 if ( $rOpts->{'dump-options'} ) {
580 print STDOUT $readable_options;
584 #---------------------------------------------------------------
585 # check parameters and their interactions
586 #---------------------------------------------------------------
588 check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
590 if ($user_formatter) {
591 $rOpts->{'format'} = 'user';
594 # there must be one entry here for every possible format
595 my %default_file_extension = (
601 $rOpts_character_encoding = $rOpts->{'character-encoding'};
603 # be sure we have a valid output format
604 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
605 my $formats = join ' ',
606 sort map { "'" . $_ . "'" } keys %default_file_extension;
607 my $fmt = $rOpts->{'format'};
608 Die("-format='$fmt' but must be one of: $formats\n");
611 my $output_extension = make_extension( $rOpts->{'output-file-extension'},
612 $default_file_extension{ $rOpts->{'format'} }, $dot );
614 # If the backup extension contains a / character then the backup should
615 # be deleted when the -b option is used. On older versions of
616 # perltidy this will generate an error message due to an illegal
619 # A backup file will still be generated but will be deleted
620 # at the end. If -bext='/' then this extension will be
621 # the default 'bak'. Otherwise it will be whatever characters
622 # remains after all '/' characters are removed. For example:
623 # -bext extension slashes
627 # '/dev/null' devnull 2 (Currently not allowed)
628 my $bext = $rOpts->{'backup-file-extension'};
629 my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
631 # At present only one forward slash is allowed. In the future multiple
632 # slashes may be allowed to allow for other options
633 if ( $delete_backup > 1 ) {
634 Die("-bext=$bext contains more than one '/'\n");
637 my $backup_extension =
638 make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
640 my $html_toc_extension =
641 make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
643 my $html_src_extension =
644 make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
646 # check for -b option;
647 # silently ignore unless beautify mode
648 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
649 && $rOpts->{'format'} eq 'tidy';
651 # Turn off -b with warnings in case of conflicts with other options.
652 # NOTE: Do this silently, without warnings, if there is a source or
653 # destination stream, or standard output is used. This is because the -b
654 # flag may have been in a .perltidyrc file and warnings break
655 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
656 if ($in_place_modify) {
657 if ( $rOpts->{'standard-output'}
658 || $destination_stream
659 || ref $source_stream
660 || $rOpts->{'outfile'}
661 || defined( $rOpts->{'output-path'} ) )
663 $in_place_modify = 0;
667 Perl::Tidy::Formatter::check_options($rOpts);
668 if ( $rOpts->{'format'} eq 'html' ) {
669 Perl::Tidy::HtmlWriter->check_options($rOpts);
672 # make the pattern of file extensions that we shouldn't touch
673 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
674 if ($output_extension) {
675 my $ext = quotemeta($output_extension);
676 $forbidden_file_extensions .= "|$ext";
678 if ( $in_place_modify && $backup_extension ) {
679 my $ext = quotemeta($backup_extension);
680 $forbidden_file_extensions .= "|$ext";
682 $forbidden_file_extensions .= ')$';
684 # Create a diagnostics object if requested;
685 # This is only useful for code development
686 my $diagnostics_object = undef;
687 if ( $rOpts->{'DIAGNOSTICS'} ) {
688 $diagnostics_object = Perl::Tidy::Diagnostics->new();
691 # no filenames should be given if input is from an array
692 if ($source_stream) {
695 "You may not specify any filenames when a source array is given\n"
699 # we'll stuff the source array into ARGV
700 unshift( @ARGV, $source_stream );
702 # No special treatment for source stream which is a filename.
703 # This will enable checks for binary files and other bad stuff.
704 $source_stream = undef unless ref($source_stream);
707 # use stdin by default if no source array and no args
709 unshift( @ARGV, '-' ) unless @ARGV;
712 #---------------------------------------------------------------
714 # main loop to process all files in argument list
715 #---------------------------------------------------------------
716 my $number_of_files = @ARGV;
717 my $formatter = undef;
718 my $tokenizer = undef;
720 # If requested, process in order of increasing file size
721 # This can significantly reduce perl's virtual memory usage during testing.
722 if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) {
725 sort { $a->[1] <=> $b->[1] }
726 map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
729 while ( my $input_file = shift @ARGV ) {
731 my $input_file_permissions;
733 #---------------------------------------------------------------
734 # prepare this input stream
735 #---------------------------------------------------------------
736 if ($source_stream) {
737 $fileroot = "perltidy";
739 # If the source is from an array or string, then .LOG output
740 # is only possible if a logfile stream is specified. This prevents
741 # unexpected perltidy.LOG files.
742 if ( !defined($logfile_stream) ) {
743 $logfile_stream = Perl::Tidy::DevNull->new();
746 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
747 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
748 $in_place_modify = 0;
751 $fileroot = $input_file;
752 unless ( -e $input_file ) {
754 # file doesn't exist - check for a file glob
755 if ( $input_file =~ /([\?\*\[\{])/ ) {
757 # Windows shell may not remove quotes, so do it
758 my $input_file = $input_file;
759 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
760 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
761 my $pattern = fileglob_to_re($input_file);
763 if ( !$@ && opendir( DIR, './' ) ) {
765 grep { /$pattern/ && !-d $_ } readdir(DIR);
768 unshift @ARGV, @files;
773 Warn("skipping file: '$input_file': no matches found\n");
777 unless ( -f $input_file ) {
778 Warn("skipping file: $input_file: not a regular file\n");
782 # As a safety precaution, skip zero length files.
783 # If for example a source file got clobbered somehow,
784 # the old .tdy or .bak files might still exist so we
785 # shouldn't overwrite them with zero length files.
786 unless ( -s $input_file ) {
787 Warn("skipping file: $input_file: Zero size\n");
791 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
793 "skipping file: $input_file: Non-text (override with -f)\n"
798 # we should have a valid filename now
799 $fileroot = $input_file;
800 $input_file_permissions = ( stat $input_file )[2] & oct(7777);
802 if ( $^O eq 'VMS' ) {
803 ( $fileroot, $dot ) = check_vms_filename($fileroot);
806 # add option to change path here
807 if ( defined( $rOpts->{'output-path'} ) ) {
809 my ( $base, $old_path ) = fileparse($fileroot);
810 my $new_path = $rOpts->{'output-path'};
811 unless ( -d $new_path ) {
812 unless ( mkdir $new_path, 0777 ) {
813 Die("unable to create directory $new_path: $!\n");
816 my $path = $new_path;
817 $fileroot = catfile( $path, $base );
820 ------------------------------------------------------------------------
821 Problem combining $new_path and $base to make a filename; check -opath
822 ------------------------------------------------------------------------
828 # Skip files with same extension as the output files because
829 # this can lead to a messy situation with files like
830 # script.tdy.tdy.tdy ... or worse problems ... when you
831 # rerun perltidy over and over with wildcard input.
834 && ( $input_file =~ /$forbidden_file_extensions/o
835 || $input_file eq 'DIAGNOSTICS' )
838 Warn("skipping file: $input_file: wrong extension\n");
842 # the 'source_object' supplies a method to read the input file
844 Perl::Tidy::LineSource->new( $input_file, $rOpts,
845 $rpending_logfile_message );
846 next unless ($source_object);
848 # Prefilters and postfilters: The prefilter is a code reference
849 # that will be applied to the source before tidying, and the
850 # postfilter is a code reference to the result before outputting.
853 || ( $rOpts_character_encoding
854 && $rOpts_character_encoding eq 'utf8' )
858 while ( my $line = $source_object->get_line() ) {
862 $buf = $prefilter->($buf) if $prefilter;
864 if ( $rOpts_character_encoding
865 && $rOpts_character_encoding eq 'utf8'
866 && !utf8::is_utf8($buf) )
869 $buf = Encode::decode( 'UTF-8', $buf,
870 Encode::FB_CROAK | Encode::LEAVE_SRC );
874 "skipping file: $input_file: Unable to decode source as UTF-8\n"
880 $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
881 $rpending_logfile_message );
884 # register this file name with the Diagnostics package
885 $diagnostics_object->set_input_file($input_file)
886 if $diagnostics_object;
888 #---------------------------------------------------------------
889 # prepare the output stream
890 #---------------------------------------------------------------
891 my $output_file = undef;
892 my $actual_output_extension;
894 if ( $rOpts->{'outfile'} ) {
896 if ( $number_of_files <= 1 ) {
898 if ( $rOpts->{'standard-output'} ) {
899 my $msg = "You may not use -o and -st together";
900 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
903 elsif ($destination_stream) {
905 "You may not specify a destination array and -o together\n"
908 elsif ( defined( $rOpts->{'output-path'} ) ) {
909 Die("You may not specify -o and -opath together\n");
911 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
912 Die("You may not specify -o and -oext together\n");
914 $output_file = $rOpts->{outfile};
916 # make sure user gives a file name after -o
917 if ( $output_file =~ /^-/ ) {
918 Die("You must specify a valid filename after -o\n");
921 # do not overwrite input file with -o
922 if ( defined($input_file_permissions)
923 && ( $output_file eq $input_file ) )
925 Die("Use 'perltidy -b $input_file' to modify in-place\n");
929 Die("You may not use -o with more than one input file\n");
932 elsif ( $rOpts->{'standard-output'} ) {
933 if ($destination_stream) {
935 "You may not specify a destination array and -st together\n";
936 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
941 if ( $number_of_files <= 1 ) {
944 Die("You may not use -st with more than one input file\n");
947 elsif ($destination_stream) {
948 $output_file = $destination_stream;
950 elsif ($source_stream) { # source but no destination goes to stdout
953 elsif ( $input_file eq '-' ) {
957 if ($in_place_modify) {
958 $output_file = IO::File->new_tmpfile()
959 or Die("cannot open temp file for -b option: $!\n");
962 $actual_output_extension = $output_extension;
963 $output_file = $fileroot . $output_extension;
967 # the 'sink_object' knows how to write the output file
968 my $tee_file = $fileroot . $dot . "TEE";
970 my $line_separator = $rOpts->{'output-line-ending'};
971 if ( $rOpts->{'preserve-line-endings'} ) {
972 $line_separator = find_input_line_ending($input_file);
975 # Eventually all I/O may be done with binmode, but for now it is
976 # only done when a user requests a particular line separator
977 # through the -ple or -ole flags
978 my $binmode = defined($line_separator)
979 || defined($rOpts_character_encoding);
980 $line_separator = "\n" unless defined($line_separator);
982 my ( $sink_object, $postfilter_buffer );
985 Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
986 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
990 Perl::Tidy::LineSink->new( $output_file, $tee_file,
991 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
994 #---------------------------------------------------------------
995 # initialize the error logger for this file
996 #---------------------------------------------------------------
997 my $warning_file = $fileroot . $dot . "ERR";
998 if ($errorfile_stream) { $warning_file = $errorfile_stream }
999 my $log_file = $fileroot . $dot . "LOG";
1000 if ($logfile_stream) { $log_file = $logfile_stream }
1003 Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
1004 $fh_stderr, $saw_extrude );
1005 write_logfile_header(
1006 $rOpts, $logger_object, $config_file,
1007 $rraw_options, $Windows_type, $readable_options,
1009 if ( ${$rpending_logfile_message} ) {
1010 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
1012 if ( ${$rpending_complaint} ) {
1013 $logger_object->complain( ${$rpending_complaint} );
1016 #---------------------------------------------------------------
1017 # initialize the debug object, if any
1018 #---------------------------------------------------------------
1019 my $debugger_object = undef;
1020 if ( $rOpts->{DEBUG} ) {
1022 Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
1025 #---------------------------------------------------------------
1026 # loop over iterations for one source stream
1027 #---------------------------------------------------------------
1029 # We will do a convergence test if 3 or more iterations are allowed.
1030 # It would be pointless for fewer because we have to make at least
1031 # two passes before we can see if we are converged, and the test
1032 # would just slow things down.
1033 my $max_iterations = $rOpts->{'iterations'};
1034 my $convergence_log_message;
1036 my $do_convergence_test = $max_iterations > 2;
1038 # Since Digest::MD5 qw(md5_hex) has been in the earliest version of Perl
1039 # we are requiring (5.8), I have commented out this check
1040 ##? if ($do_convergence_test) {
1041 ##? eval "use Digest::MD5 qw(md5_hex)";
1042 ##? $do_convergence_test = !$@;
1044 ##? ### Trying to avoid problems with ancient versions of perl
1045 ##? ##eval { my $string = "perltidy"; utf8::encode($string) };
1046 ##? ##$do_convergence_test = $do_convergence_test && !$@;
1049 # save objects to allow redirecting output during iterations
1050 my $sink_object_final = $sink_object;
1051 my $debugger_object_final = $debugger_object;
1052 my $logger_object_final = $logger_object;
1054 foreach my $iter ( 1 .. $max_iterations ) {
1056 # send output stream to temp buffers until last iteration
1058 if ( $iter < $max_iterations ) {
1060 Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
1061 $line_separator, $rOpts, $rpending_logfile_message,
1065 $sink_object = $sink_object_final;
1068 # Save logger, debugger output only on pass 1 because:
1069 # (1) line number references must be to the starting
1070 # source, not an intermediate result, and
1071 # (2) we need to know if there are errors so we can stop the
1072 # iterations early if necessary.
1074 $debugger_object = undef;
1075 $logger_object = undef;
1078 #------------------------------------------------------------
1079 # create a formatter for this file : html writer or
1081 #------------------------------------------------------------
1083 # we have to delete any old formatter because, for safety,
1084 # the formatter will check to see that there is only one.
1087 if ($user_formatter) {
1088 $formatter = $user_formatter;
1090 elsif ( $rOpts->{'format'} eq 'html' ) {
1092 Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
1093 $actual_output_extension, $html_toc_extension,
1094 $html_src_extension );
1096 elsif ( $rOpts->{'format'} eq 'tidy' ) {
1097 $formatter = Perl::Tidy::Formatter->new(
1098 logger_object => $logger_object,
1099 diagnostics_object => $diagnostics_object,
1100 sink_object => $sink_object,
1104 Die("I don't know how to do -format=$rOpts->{'format'}\n");
1107 unless ($formatter) {
1108 Die("Unable to continue with $rOpts->{'format'} formatting\n");
1111 #---------------------------------------------------------------
1112 # create the tokenizer for this file
1113 #---------------------------------------------------------------
1114 $tokenizer = undef; # must destroy old tokenizer
1115 $tokenizer = Perl::Tidy::Tokenizer->new(
1116 source_object => $source_object,
1117 logger_object => $logger_object,
1118 debugger_object => $debugger_object,
1119 diagnostics_object => $diagnostics_object,
1120 tabsize => $tabsize,
1122 starting_level => $rOpts->{'starting-indentation-level'},
1123 indent_columns => $rOpts->{'indent-columns'},
1124 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
1125 look_for_autoloader => $rOpts->{'look-for-autoloader'},
1126 look_for_selfloader => $rOpts->{'look-for-selfloader'},
1127 trim_qw => $rOpts->{'trim-qw'},
1128 extended_syntax => $rOpts->{'extended-syntax'},
1130 continuation_indentation =>
1131 $rOpts->{'continuation-indentation'},
1132 outdent_labels => $rOpts->{'outdent-labels'},
1135 #---------------------------------------------------------------
1137 #---------------------------------------------------------------
1138 process_this_file( $tokenizer, $formatter );
1140 #---------------------------------------------------------------
1141 # close the input source and report errors
1142 #---------------------------------------------------------------
1143 $source_object->close_input_file();
1145 # line source for next iteration (if any) comes from the current
1146 # temporary output buffer
1147 if ( $iter < $max_iterations ) {
1149 $sink_object->close_output_file();
1151 Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
1152 $rpending_logfile_message );
1154 # stop iterations if errors or converged
1155 #my $stop_now = $logger_object->{_warning_count};
1156 my $stop_now = $tokenizer->report_tokenization_errors();
1158 $convergence_log_message = <<EOM;
1159 Stopping iterations because of severe errors.
1162 elsif ($do_convergence_test) {
1164 # Patch for [rt.cpan.org #88020]
1165 # Use utf8::encode since md5_hex() only operates on bytes.
1166 # my $digest = md5_hex( utf8::encode($sink_buffer) );
1168 # Note added 20180114: this patch did not work correctly.
1169 # I'm not sure why. But switching to the method
1170 # recommended in the Perl 5 documentation for Encode
1171 # worked. According to this we can either use
1172 # $octets = encode_utf8($string) or equivalently
1173 # $octets = encode("utf8",$string)
1174 # and then calculate the checksum. So:
1175 my $octets = Encode::encode( "utf8", $sink_buffer );
1176 my $digest = md5_hex($octets);
1177 if ( !$saw_md5{$digest} ) {
1178 $saw_md5{$digest} = $iter;
1182 # Deja vu, stop iterating
1184 my $iterm = $iter - 1;
1185 if ( $saw_md5{$digest} != $iterm ) {
1187 # Blinking (oscillating) between two stable
1188 # end states. This has happened in the past
1189 # but at present there are no known instances.
1190 $convergence_log_message = <<EOM;
1191 Blinking. Output for iteration $iter same as for $saw_md5{$digest}.
1193 $diagnostics_object->write_diagnostics(
1194 $convergence_log_message)
1195 if $diagnostics_object;
1198 $convergence_log_message = <<EOM;
1199 Converged. Output for iteration $iter same as for iter $iterm.
1201 $diagnostics_object->write_diagnostics(
1202 $convergence_log_message)
1203 if $diagnostics_object && $iterm > 2;
1206 } ## end if ($do_convergence_test)
1210 # we are stopping the iterations early;
1211 # copy the output stream to its final destination
1212 $sink_object = $sink_object_final;
1213 while ( my $line = $source_object->get_line() ) {
1214 $sink_object->write_line($line);
1216 $source_object->close_input_file();
1219 } ## end if ( $iter < $max_iterations)
1220 } # end loop over iterations for one source file
1222 # restore objects which have been temporarily undefined
1223 # for second and higher iterations
1224 $debugger_object = $debugger_object_final;
1225 $logger_object = $logger_object_final;
1227 $logger_object->write_logfile_entry($convergence_log_message)
1228 if $convergence_log_message;
1230 #---------------------------------------------------------------
1231 # Perform any postfilter operation
1232 #---------------------------------------------------------------
1234 $sink_object->close_output_file();
1236 Perl::Tidy::LineSink->new( $output_file, $tee_file,
1237 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
1238 my $buf = $postfilter->($postfilter_buffer);
1240 Perl::Tidy::LineSource->new( \$buf, $rOpts,
1241 $rpending_logfile_message );
1242 while ( my $line = $source_object->get_line() ) {
1243 $sink_object->write_line($line);
1245 $source_object->close_input_file();
1248 # Save names of the input and output files for syntax check
1249 my $ifname = $input_file;
1250 my $ofname = $output_file;
1252 #---------------------------------------------------------------
1253 # handle the -b option (backup and modify in-place)
1254 #---------------------------------------------------------------
1255 if ($in_place_modify) {
1256 unless ( -f $input_file ) {
1258 # oh, oh, no real file to backup ..
1259 # shouldn't happen because of numerous preliminary checks
1261 "problem with -b backing up input file '$input_file': not a file\n"
1264 my $backup_name = $input_file . $backup_extension;
1265 if ( -f $backup_name ) {
1266 unlink($backup_name)
1268 "unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
1272 # backup the input file
1273 # we use copy for symlinks, move for regular files
1274 if ( -l $input_file ) {
1275 File::Copy::copy( $input_file, $backup_name )
1276 or Die("File::Copy failed trying to backup source: $!");
1279 rename( $input_file, $backup_name )
1281 "problem renaming $input_file to $backup_name for -b option: $!\n"
1284 $ifname = $backup_name;
1286 # copy the output to the original input file
1287 # NOTE: it would be nice to just close $output_file and use
1288 # File::Copy::copy here, but in this case $output_file is the
1289 # handle of an open nameless temporary file so we would lose
1290 # everything if we closed it.
1291 seek( $output_file, 0, 0 )
1292 or Die("unable to rewind a temporary file for -b option: $!\n");
1293 my $fout = IO::File->new("> $input_file")
1295 "problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
1298 if ( $rOpts->{'character-encoding'}
1299 && $rOpts->{'character-encoding'} eq 'utf8' )
1301 binmode $fout, ":encoding(UTF-8)";
1303 else { binmode $fout }
1306 while ( $line = $output_file->getline() ) {
1307 $fout->print($line);
1310 $output_file = $input_file;
1311 $ofname = $input_file;
1314 #---------------------------------------------------------------
1315 # clean up and report errors
1316 #---------------------------------------------------------------
1317 $sink_object->close_output_file() if $sink_object;
1318 $debugger_object->close_debug_file() if $debugger_object;
1320 # set output file permissions
1321 if ( $output_file && -f $output_file && !-l $output_file ) {
1322 if ($input_file_permissions) {
1324 # give output script same permissions as input script, but
1325 # make it user-writable or else we can't run perltidy again.
1326 # Thus we retain whatever executable flags were set.
1327 if ( $rOpts->{'format'} eq 'tidy' ) {
1328 chmod( $input_file_permissions | oct(600), $output_file );
1331 # else use default permissions for html and any other format
1335 #---------------------------------------------------------------
1336 # Do syntax check if requested and possible
1337 #---------------------------------------------------------------
1338 my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes
1340 && $rOpts->{'check-syntax'}
1345 check_syntax( $ifname, $ofname, $logger_object, $rOpts );
1348 #---------------------------------------------------------------
1349 # remove the original file for in-place modify as follows:
1350 # $delete_backup=0 never
1351 # $delete_backup=1 only if no errors
1352 # $delete_backup>1 always : NOT ALLOWED, too risky, see above
1353 #---------------------------------------------------------------
1354 if ( $in_place_modify
1357 && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
1360 # As an added safety precaution, do not delete the source file
1361 # if its size has dropped from positive to zero, since this
1362 # could indicate a disaster of some kind, including a hardware
1363 # failure. Actually, this could happen if you had a file of
1364 # all comments (or pod) and deleted everything with -dac (-dap)
1366 if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
1368 "output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
1374 "unable to remove previous '$ifname' for -b option; check permissions: $!\n"
1379 $logger_object->finish( $infile_syntax_ok, $formatter )
1381 } # end of main loop to process all files
1388 } # end of main program perltidy
1390 sub get_stream_as_named_file {
1392 # Return the name of a file containing a stream of data, creating
1393 # a temporary file if necessary.
1395 # $stream - the name of a file or stream
1397 # $fname = name of file if possible, or undef
1398 # $if_tmpfile = true if temp file, undef if not temp file
1400 # This routine is needed for passing actual files to Perl for
1406 if ( ref($stream) ) {
1407 my ( $fh_stream, $fh_name ) =
1408 Perl::Tidy::streamhandle( $stream, 'r' );
1410 my ( $fout, $tmpnam ) = File::Temp::tempfile();
1415 while ( my $line = $fh_stream->getline() ) {
1416 $fout->print($line);
1420 $fh_stream->close();
1423 elsif ( $stream ne '-' && -f $stream ) {
1427 return ( $fname, $is_tmpfile );
1430 sub fileglob_to_re {
1432 # modified (corrected) from version in find2perl
1434 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
1435 $x =~ s#\*#.*#g; # '*' -> '.*'
1436 $x =~ s#\?#.#g; # '?' -> '.'
1437 return "^$x\\z"; # match whole word
1440 sub make_extension {
1442 # Make a file extension, including any leading '.' if necessary
1443 # The '.' may actually be an '_' under VMS
1444 my ( $extension, $default, $dot ) = @_;
1446 # Use the default if none specified
1447 $extension = $default unless ($extension);
1449 # Only extensions with these leading characters get a '.'
1450 # This rule gives the user some freedom
1451 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
1452 $extension = $dot . $extension;
1457 sub write_logfile_header {
1459 $rOpts, $logger_object, $config_file,
1460 $rraw_options, $Windows_type, $readable_options
1462 $logger_object->write_logfile_entry(
1463 "perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
1465 if ($Windows_type) {
1466 $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
1468 my $options_string = join( ' ', @{$rraw_options} );
1471 $logger_object->write_logfile_entry(
1472 "Found Configuration File >>> $config_file \n");
1474 $logger_object->write_logfile_entry(
1475 "Configuration and command line parameters for this run:\n");
1476 $logger_object->write_logfile_entry("$options_string\n");
1478 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
1479 $rOpts->{'logfile'} = 1; # force logfile to be saved
1480 $logger_object->write_logfile_entry(
1481 "Final parameter set for this run\n");
1482 $logger_object->write_logfile_entry(
1483 "------------------------------------\n");
1485 $logger_object->write_logfile_entry($readable_options);
1487 $logger_object->write_logfile_entry(
1488 "------------------------------------\n");
1490 $logger_object->write_logfile_entry(
1491 "To find error messages search for 'WARNING' with your editor\n");
1495 sub generate_options {
1497 ######################################################################
1498 # Generate and return references to:
1499 # @option_string - the list of options to be passed to Getopt::Long
1500 # @defaults - the list of default options
1501 # %expansion - a hash showing how all abbreviations are expanded
1502 # %category - a hash giving the general category of each option
1503 # %option_range - a hash giving the valid ranges of certain options
1505 # Note: a few options are not documented in the man page and usage
1506 # message. This is because these are experimental or debug options and
1507 # may or may not be retained in future versions.
1509 # Here are the undocumented flags as far as I know. Any of them
1510 # may disappear at any time. They are mainly for fine-tuning
1513 # fll --> fuzzy-line-length # a trivial parameter which gets
1514 # turned off for the extrude option
1515 # which is mainly for debugging
1516 # scl --> short-concatenation-item-length # helps break at '.'
1517 # recombine # for debugging line breaks
1518 # valign # for debugging vertical alignment
1519 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
1520 ######################################################################
1522 # here is a summary of the Getopt codes:
1523 # <none> does not take an argument
1524 # =s takes a mandatory string
1525 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
1526 # =i takes a mandatory integer
1527 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
1528 # ! does not take an argument and may be negated
1529 # i.e., -foo and -nofoo are allowed
1530 # a double dash signals the end of the options list
1532 #---------------------------------------------------------------
1533 # Define the option string passed to GetOptions.
1534 #---------------------------------------------------------------
1536 my @option_string = ();
1538 my %option_category = ();
1539 my %option_range = ();
1540 my $rexpansion = \%expansion;
1542 # names of categories in manual
1543 # leading integers will allow sorting
1544 my @category_name = (
1546 '1. Basic formatting options',
1547 '2. Code indentation control',
1548 '3. Whitespace control',
1549 '4. Comment controls',
1550 '5. Linebreak controls',
1551 '6. Controlling list formatting',
1552 '7. Retaining or ignoring existing line breaks',
1553 '8. Blank line control',
1554 '9. Other controls',
1556 '11. pod2html options',
1557 '12. Controlling HTML properties',
1561 # These options are parsed directly by perltidy:
1564 # However, they are included in the option set so that they will
1565 # be seen in the options dump.
1567 # These long option names have no abbreviations or are treated specially
1568 @option_string = qw(
1578 my $category = 13; # Debugging
1579 foreach (@option_string) {
1580 my $opt = $_; # must avoid changing the actual flag
1582 $option_category{$opt} = $category_name[$category];
1585 $category = 11; # HTML
1586 $option_category{html} = $category_name[$category];
1588 # routine to install and check options
1589 my $add_option = sub {
1590 my ( $long_name, $short_name, $flag ) = @_;
1591 push @option_string, $long_name . $flag;
1592 $option_category{$long_name} = $category_name[$category];
1594 if ( $expansion{$short_name} ) {
1595 my $existing_name = $expansion{$short_name}[0];
1597 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
1600 $expansion{$short_name} = [$long_name];
1601 if ( $flag eq '!' ) {
1602 my $nshort_name = 'n' . $short_name;
1603 my $nolong_name = 'no' . $long_name;
1604 if ( $expansion{$nshort_name} ) {
1605 my $existing_name = $expansion{$nshort_name}[0];
1607 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
1610 $expansion{$nshort_name} = [$nolong_name];
1615 # Install long option names which have a simple abbreviation.
1616 # Options with code '!' get standard negation ('no' for long names,
1617 # 'n' for abbreviations). Categories follow the manual.
1619 ###########################
1620 $category = 0; # I/O_Control
1621 ###########################
1622 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
1623 $add_option->( 'backup-file-extension', 'bext', '=s' );
1624 $add_option->( 'force-read-binary', 'f', '!' );
1625 $add_option->( 'format', 'fmt', '=s' );
1626 $add_option->( 'iterations', 'it', '=i' );
1627 $add_option->( 'logfile', 'log', '!' );
1628 $add_option->( 'logfile-gap', 'g', ':i' );
1629 $add_option->( 'outfile', 'o', '=s' );
1630 $add_option->( 'output-file-extension', 'oext', '=s' );
1631 $add_option->( 'output-path', 'opath', '=s' );
1632 $add_option->( 'profile', 'pro', '=s' );
1633 $add_option->( 'quiet', 'q', '!' );
1634 $add_option->( 'standard-error-output', 'se', '!' );
1635 $add_option->( 'standard-output', 'st', '!' );
1636 $add_option->( 'warning-output', 'w', '!' );
1637 $add_option->( 'character-encoding', 'enc', '=s' );
1639 # options which are both toggle switches and values moved here
1640 # to hide from tidyview (which does not show category 0 flags):
1641 # -ole moved here from category 1
1642 # -sil moved here from category 2
1643 $add_option->( 'output-line-ending', 'ole', '=s' );
1644 $add_option->( 'starting-indentation-level', 'sil', '=i' );
1646 ########################################
1647 $category = 1; # Basic formatting options
1648 ########################################
1649 $add_option->( 'check-syntax', 'syn', '!' );
1650 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
1651 $add_option->( 'indent-columns', 'i', '=i' );
1652 $add_option->( 'maximum-line-length', 'l', '=i' );
1653 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
1654 $add_option->( 'whitespace-cycle', 'wc', '=i' );
1655 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
1656 $add_option->( 'preserve-line-endings', 'ple', '!' );
1657 $add_option->( 'tabs', 't', '!' );
1658 $add_option->( 'default-tabsize', 'dt', '=i' );
1659 $add_option->( 'extended-syntax', 'xs', '!' );
1661 ########################################
1662 $category = 2; # Code indentation control
1663 ########################################
1664 $add_option->( 'continuation-indentation', 'ci', '=i' );
1665 $add_option->( 'line-up-parentheses', 'lp', '!' );
1666 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
1667 $add_option->( 'outdent-keywords', 'okw', '!' );
1668 $add_option->( 'outdent-labels', 'ola', '!' );
1669 $add_option->( 'outdent-long-quotes', 'olq', '!' );
1670 $add_option->( 'indent-closing-brace', 'icb', '!' );
1671 $add_option->( 'closing-token-indentation', 'cti', '=i' );
1672 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
1673 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
1674 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
1675 $add_option->( 'brace-left-and-indent', 'bli', '!' );
1676 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
1678 ########################################
1679 $category = 3; # Whitespace control
1680 ########################################
1681 $add_option->( 'add-semicolons', 'asc', '!' );
1682 $add_option->( 'add-whitespace', 'aws', '!' );
1683 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
1684 $add_option->( 'brace-tightness', 'bt', '=i' );
1685 $add_option->( 'delete-old-whitespace', 'dws', '!' );
1686 $add_option->( 'delete-semicolons', 'dsm', '!' );
1687 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
1688 $add_option->( 'nowant-left-space', 'nwls', '=s' );
1689 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
1690 $add_option->( 'paren-tightness', 'pt', '=i' );
1691 $add_option->( 'space-after-keyword', 'sak', '=s' );
1692 $add_option->( 'space-for-semicolon', 'sfs', '!' );
1693 $add_option->( 'space-function-paren', 'sfp', '!' );
1694 $add_option->( 'space-keyword-paren', 'skp', '!' );
1695 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
1696 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
1697 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
1698 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
1699 $add_option->( 'tight-secret-operators', 'tso', '!' );
1700 $add_option->( 'trim-qw', 'tqw', '!' );
1701 $add_option->( 'trim-pod', 'trp', '!' );
1702 $add_option->( 'want-left-space', 'wls', '=s' );
1703 $add_option->( 'want-right-space', 'wrs', '=s' );
1705 ########################################
1706 $category = 4; # Comment controls
1707 ########################################
1708 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
1709 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
1710 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
1711 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
1712 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
1713 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
1714 $add_option->( 'closing-side-comments', 'csc', '!' );
1715 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
1716 $add_option->( 'format-skipping', 'fs', '!' );
1717 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
1718 $add_option->( 'format-skipping-end', 'fse', '=s' );
1719 $add_option->( 'hanging-side-comments', 'hsc', '!' );
1720 $add_option->( 'indent-block-comments', 'ibc', '!' );
1721 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
1722 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
1723 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
1724 $add_option->( 'outdent-long-comments', 'olc', '!' );
1725 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
1726 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
1727 $add_option->( 'static-block-comments', 'sbc', '!' );
1728 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
1729 $add_option->( 'static-side-comments', 'ssc', '!' );
1730 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
1732 ########################################
1733 $category = 5; # Linebreak controls
1734 ########################################
1735 $add_option->( 'add-newlines', 'anl', '!' );
1736 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
1737 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
1738 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
1739 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
1740 $add_option->( 'cuddled-else', 'ce', '!' );
1741 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
1742 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
1743 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
1744 $add_option->( 'delete-old-newlines', 'dnl', '!' );
1745 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
1746 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
1747 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
1748 $add_option->( 'opening-paren-right', 'opr', '!' );
1749 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
1750 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
1751 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
1752 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
1753 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
1754 $add_option->( 'weld-nested-containers', 'wn', '!' );
1755 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
1756 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
1757 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
1758 $add_option->( 'stack-closing-paren', 'scp', '!' );
1759 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
1760 $add_option->( 'stack-opening-block-brace', 'sobb', '!' );
1761 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
1762 $add_option->( 'stack-opening-paren', 'sop', '!' );
1763 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
1764 $add_option->( 'vertical-tightness', 'vt', '=i' );
1765 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
1766 $add_option->( 'want-break-after', 'wba', '=s' );
1767 $add_option->( 'want-break-before', 'wbb', '=s' );
1768 $add_option->( 'break-after-all-operators', 'baao', '!' );
1769 $add_option->( 'break-before-all-operators', 'bbao', '!' );
1770 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
1772 ########################################
1773 $category = 6; # Controlling list formatting
1774 ########################################
1775 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
1776 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
1777 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
1779 ########################################
1780 $category = 7; # Retaining or ignoring existing line breaks
1781 ########################################
1782 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
1783 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
1784 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
1785 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
1786 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
1788 ########################################
1789 $category = 8; # Blank line control
1790 ########################################
1791 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
1792 $add_option->( 'blanks-before-comments', 'bbc', '!' );
1793 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
1794 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
1795 $add_option->( 'long-block-line-count', 'lbl', '=i' );
1796 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
1797 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
1799 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
1800 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
1801 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
1802 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
1804 ########################################
1805 $category = 9; # Other controls
1806 ########################################
1807 $add_option->( 'delete-block-comments', 'dbc', '!' );
1808 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
1809 $add_option->( 'delete-pod', 'dp', '!' );
1810 $add_option->( 'delete-side-comments', 'dsc', '!' );
1811 $add_option->( 'tee-block-comments', 'tbc', '!' );
1812 $add_option->( 'tee-pod', 'tp', '!' );
1813 $add_option->( 'tee-side-comments', 'tsc', '!' );
1814 $add_option->( 'look-for-autoloader', 'lal', '!' );
1815 $add_option->( 'look-for-hash-bang', 'x', '!' );
1816 $add_option->( 'look-for-selfloader', 'lsl', '!' );
1817 $add_option->( 'pass-version-line', 'pvl', '!' );
1819 ########################################
1820 $category = 13; # Debugging
1821 ########################################
1822 ## $add_option->( 'DIAGNOSTICS', 'I', '!' );
1823 $add_option->( 'DEBUG', 'D', '!' );
1824 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
1825 $add_option->( 'dump-defaults', 'ddf', '!' );
1826 $add_option->( 'dump-long-names', 'dln', '!' );
1827 $add_option->( 'dump-options', 'dop', '!' );
1828 $add_option->( 'dump-profile', 'dpro', '!' );
1829 $add_option->( 'dump-short-names', 'dsn', '!' );
1830 $add_option->( 'dump-token-types', 'dtt', '!' );
1831 $add_option->( 'dump-want-left-space', 'dwls', '!' );
1832 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
1833 $add_option->( 'fuzzy-line-length', 'fll', '!' );
1834 $add_option->( 'help', 'h', '' );
1835 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
1836 $add_option->( 'show-options', 'opt', '!' );
1837 $add_option->( 'timestamp', 'ts', '!' );
1838 $add_option->( 'version', 'v', '' );
1839 $add_option->( 'memoize', 'mem', '!' );
1840 $add_option->( 'file-size-order', 'fso', '!' );
1842 #---------------------------------------------------------------------
1844 # The Perl::Tidy::HtmlWriter will add its own options to the string
1845 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
1847 ########################################
1848 # Set categories 10, 11, 12
1849 ########################################
1850 # Based on their known order
1851 $category = 12; # HTML properties
1852 foreach my $opt (@option_string) {
1853 my $long_name = $opt;
1854 $long_name =~ s/(!|=.*|:.*)$//;
1855 unless ( defined( $option_category{$long_name} ) ) {
1856 if ( $long_name =~ /^html-linked/ ) {
1857 $category = 10; # HTML options
1859 elsif ( $long_name =~ /^pod2html/ ) {
1860 $category = 11; # Pod2html
1862 $option_category{$long_name} = $category_name[$category];
1866 #---------------------------------------------------------------
1867 # Assign valid ranges to certain options
1868 #---------------------------------------------------------------
1869 # In the future, these may be used to make preliminary checks
1870 # hash keys are long names
1871 # If key or value is undefined:
1872 # strings may have any value
1873 # integer ranges are >=0
1874 # If value is defined:
1875 # value is [qw(any valid words)] for strings
1876 # value is [min, max] for integers
1877 # if min is undefined, there is no lower limit
1878 # if max is undefined, there is no upper limit
1879 # Parameters not listed here have defaults
1881 'format' => [ 'tidy', 'html', 'user' ],
1882 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
1883 'character-encoding' => [ 'none', 'utf8' ],
1885 'space-backslash-quote' => [ 0, 2 ],
1887 'block-brace-tightness' => [ 0, 2 ],
1888 'brace-tightness' => [ 0, 2 ],
1889 'paren-tightness' => [ 0, 2 ],
1890 'square-bracket-tightness' => [ 0, 2 ],
1892 'block-brace-vertical-tightness' => [ 0, 2 ],
1893 'brace-vertical-tightness' => [ 0, 2 ],
1894 'brace-vertical-tightness-closing' => [ 0, 2 ],
1895 'paren-vertical-tightness' => [ 0, 2 ],
1896 'paren-vertical-tightness-closing' => [ 0, 2 ],
1897 'square-bracket-vertical-tightness' => [ 0, 2 ],
1898 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
1899 'vertical-tightness' => [ 0, 2 ],
1900 'vertical-tightness-closing' => [ 0, 2 ],
1902 'closing-brace-indentation' => [ 0, 3 ],
1903 'closing-paren-indentation' => [ 0, 3 ],
1904 'closing-square-bracket-indentation' => [ 0, 3 ],
1905 'closing-token-indentation' => [ 0, 3 ],
1907 'closing-side-comment-else-flag' => [ 0, 2 ],
1908 'comma-arrow-breakpoints' => [ 0, 5 ],
1911 # Note: we could actually allow negative ci if someone really wants it:
1912 # $option_range{'continuation-indentation'} = [ undef, undef ];
1914 #---------------------------------------------------------------
1915 # Assign default values to the above options here, except
1916 # for 'outfile' and 'help'.
1917 # These settings should approximate the perlstyle(1) suggestions.
1918 #---------------------------------------------------------------
1923 blanks-before-blocks
1924 blanks-before-comments
1925 blank-lines-before-subs=1
1926 blank-lines-before-packages=1
1927 block-brace-tightness=0
1928 block-brace-vertical-tightness=0
1930 brace-vertical-tightness-closing=0
1931 brace-vertical-tightness=0
1932 break-at-old-logical-breakpoints
1933 break-at-old-ternary-breakpoints
1934 break-at-old-attribute-breakpoints
1935 break-at-old-keyword-breakpoints
1936 comma-arrow-breakpoints=5
1938 closing-side-comment-interval=6
1939 closing-side-comment-maximum-text=20
1940 closing-side-comment-else-flag=0
1941 closing-side-comments-balanced
1942 closing-paren-indentation=0
1943 closing-brace-indentation=0
1944 closing-square-bracket-indentation=0
1945 continuation-indentation=2
1946 cuddled-break-option=1
1951 hanging-side-comments
1952 indent-block-comments
1955 keep-old-blank-lines=1
1956 long-block-line-count=8
1959 maximum-consecutive-blank-lines=1
1960 maximum-fields-per-table=0
1961 maximum-line-length=80
1963 minimum-space-to-comment=4
1964 nobrace-left-and-indent
1966 nodelete-old-whitespace
1971 nostatic-side-comments
1974 character-encoding=none
1977 outdent-long-comments
1979 paren-vertical-tightness-closing=0
1980 paren-vertical-tightness=0
1982 noweld-nested-containers
1985 short-concatenation-item-length=8
1987 space-backslash-quote=1
1988 square-bracket-tightness=1
1989 square-bracket-vertical-tightness-closing=0
1990 square-bracket-vertical-tightness=0
1991 static-block-comments
1995 backup-file-extension=bak
2000 html-table-of-contents
2004 push @defaults, "perl-syntax-check-flags=-c -T";
2006 #---------------------------------------------------------------
2007 # Define abbreviations which will be expanded into the above primitives.
2008 # These may be defined recursively.
2009 #---------------------------------------------------------------
2012 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
2013 'fnl' => [qw(freeze-newlines)],
2014 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
2015 'fws' => [qw(freeze-whitespace)],
2016 'freeze-blank-lines' =>
2017 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
2018 'fbl' => [qw(freeze-blank-lines)],
2019 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
2020 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
2021 'nooutdent-long-lines' =>
2022 [qw(nooutdent-long-quotes nooutdent-long-comments)],
2023 'noll' => [qw(nooutdent-long-lines)],
2024 'io' => [qw(indent-only)],
2025 'delete-all-comments' =>
2026 [qw(delete-block-comments delete-side-comments delete-pod)],
2027 'nodelete-all-comments' =>
2028 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
2029 'dac' => [qw(delete-all-comments)],
2030 'ndac' => [qw(nodelete-all-comments)],
2031 'gnu' => [qw(gnu-style)],
2032 'pbp' => [qw(perl-best-practices)],
2033 'tee-all-comments' =>
2034 [qw(tee-block-comments tee-side-comments tee-pod)],
2035 'notee-all-comments' =>
2036 [qw(notee-block-comments notee-side-comments notee-pod)],
2037 'tac' => [qw(tee-all-comments)],
2038 'ntac' => [qw(notee-all-comments)],
2039 'html' => [qw(format=html)],
2040 'nhtml' => [qw(format=tidy)],
2041 'tidy' => [qw(format=tidy)],
2043 # -cb is now a synonym for -ce
2044 'cb' => [qw(cuddled-else)],
2045 'cuddled-blocks' => [qw(cuddled-else)],
2047 'utf8' => [qw(character-encoding=utf8)],
2048 'UTF8' => [qw(character-encoding=utf8)],
2050 'swallow-optional-blank-lines' => [qw(kbl=0)],
2051 'noswallow-optional-blank-lines' => [qw(kbl=1)],
2052 'sob' => [qw(kbl=0)],
2053 'nsob' => [qw(kbl=1)],
2055 'break-after-comma-arrows' => [qw(cab=0)],
2056 'nobreak-after-comma-arrows' => [qw(cab=1)],
2057 'baa' => [qw(cab=0)],
2058 'nbaa' => [qw(cab=1)],
2060 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
2061 'bbs' => [qw(blbs=1 blbp=1)],
2062 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
2063 'nbbs' => [qw(blbs=0 blbp=0)],
2065 'break-at-old-trinary-breakpoints' => [qw(bot)],
2067 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
2068 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
2069 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
2070 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
2071 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
2073 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
2074 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
2075 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
2076 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
2077 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
2079 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2080 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2081 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2083 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
2084 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
2085 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
2087 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2088 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2089 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2091 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
2092 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
2093 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
2095 'otr' => [qw(opr ohbr osbr)],
2096 'opening-token-right' => [qw(opr ohbr osbr)],
2097 'notr' => [qw(nopr nohbr nosbr)],
2098 'noopening-token-right' => [qw(nopr nohbr nosbr)],
2100 'sot' => [qw(sop sohb sosb)],
2101 'nsot' => [qw(nsop nsohb nsosb)],
2102 'stack-opening-tokens' => [qw(sop sohb sosb)],
2103 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
2105 'sct' => [qw(scp schb scsb)],
2106 'stack-closing-tokens' => => [qw(scp schb scsb)],
2107 'nsct' => [qw(nscp nschb nscsb)],
2108 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
2110 'sac' => [qw(sot sct)],
2111 'nsac' => [qw(nsot nsct)],
2112 'stack-all-containers' => [qw(sot sct)],
2113 'nostack-all-containers' => [qw(nsot nsct)],
2115 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2116 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2117 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2118 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
2119 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
2120 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
2122 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
2123 'sobb' => [qw(bbvt=2 bbvtl=*)],
2124 'nostack-opening-block-brace' => [qw(bbvt=0)],
2125 'nsobb' => [qw(bbvt=0)],
2127 'converge' => [qw(it=4)],
2128 'noconverge' => [qw(it=1)],
2129 'conv' => [qw(it=4)],
2130 'nconv' => [qw(it=1)],
2132 # 'mangle' originally deleted pod and comments, but to keep it
2133 # reversible, it no longer does. But if you really want to
2134 # delete them, just use:
2137 # An interesting use for 'mangle' is to do this:
2138 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
2139 # which will form as many one-line blocks as possible
2144 keep-old-blank-lines=0
2146 delete-old-whitespace
2149 maximum-consecutive-blank-lines=0
2150 maximum-line-length=100000
2154 noblanks-before-blocks
2155 blank-lines-before-subs=0
2156 blank-lines-before-packages=0
2161 # 'extrude' originally deleted pod and comments, but to keep it
2162 # reversible, it no longer does. But if you really want to
2163 # delete them, just use
2166 # An interesting use for 'extrude' is to do this:
2167 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
2168 # which will break up all one-line blocks.
2170 # Removed 'check-syntax' option, which is unsafe because it may execute
2171 # code in BEGIN blocks. Example 'Moose/debugger-duck_type.t'.
2177 delete-old-whitespace
2180 maximum-consecutive-blank-lines=0
2181 maximum-line-length=1
2184 noblanks-before-blocks
2185 blank-lines-before-subs=0
2186 blank-lines-before-packages=0
2193 # this style tries to follow the GNU Coding Standards (which do
2194 # not really apply to perl but which are followed by some perl
2198 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
2202 # Style suggested in Damian Conway's Perl Best Practices
2203 'perl-best-practices' => [
2204 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
2205 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
2208 # Additional styles can be added here
2211 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
2213 # Uncomment next line to dump all expansions for debugging:
2214 # dump_short_names(\%expansion);
2216 \@option_string, \@defaults, \%expansion,
2217 \%option_category, \%option_range
2220 } # end of generate_options
2222 # Memoize process_command_line. Given same @ARGV passed in, return same
2223 # values and same @ARGV back.
2224 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
2225 # up masontidy (https://metacpan.org/module/masontidy)
2227 my %process_command_line_cache;
2229 sub process_command_line {
2233 $perltidyrc_stream, $is_Windows, $Windows_type,
2234 $rpending_complaint, $dump_options_type
2237 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
2239 my $cache_key = join( chr(28), @ARGV );
2240 if ( my $result = $process_command_line_cache{$cache_key} ) {
2241 my ( $argv, @retvals ) = @{$result};
2246 my @retvals = _process_command_line(@q);
2247 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
2248 if $retvals[0]->{'memoize'};
2253 return _process_command_line(@q);
2257 # This is the original coding, which worked,
2258 # but I've rewritten it (above) to keep Perl-Critic from complaining
2262 sub process_command_line {
2265 $perltidyrc_stream, $is_Windows, $Windows_type,
2266 $rpending_complaint, $dump_options_type
2269 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
2271 my $cache_key = join( chr(28), @ARGV );
2272 if ( my $result = $process_command_line_cache{$cache_key} ) {
2273 my ( $argv, @retvals ) = @{$result};
2278 my @retvals = _process_command_line(@_);
2279 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
2280 if $retvals[0]->{'memoize'};
2285 return _process_command_line(@_);
2290 # (note the underscore here)
2291 sub _process_command_line {
2294 $perltidyrc_stream, $is_Windows, $Windows_type,
2295 $rpending_complaint, $dump_options_type
2300 # Save any current Getopt::Long configuration
2301 # and set to Getopt::Long defaults. Use eval to avoid
2302 # breaking old versions of Perl without these routines.
2303 # Previous configuration is reset at the exit of this routine.
2305 eval { $glc = Getopt::Long::Configure() };
2307 eval { Getopt::Long::ConfigDefaults() };
2309 else { $glc = undef }
2312 $roption_string, $rdefaults, $rexpansion,
2313 $roption_category, $roption_range
2314 ) = generate_options();
2316 #---------------------------------------------------------------
2317 # set the defaults by passing the above list through GetOptions
2318 #---------------------------------------------------------------
2323 # do not load the defaults if we are just dumping perltidyrc
2324 unless ( $dump_options_type eq 'perltidyrc' ) {
2325 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
2327 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2329 "Programming Bug reported by 'GetOptions': error in setting default options"
2335 my @raw_options = ();
2336 my $config_file = "";
2337 my $saw_ignore_profile = 0;
2338 my $saw_dump_profile = 0;
2340 #---------------------------------------------------------------
2341 # Take a first look at the command-line parameters. Do as many
2342 # immediate dumps as possible, which can avoid confusion if the
2343 # perltidyrc file has an error.
2344 #---------------------------------------------------------------
2345 foreach my $i (@ARGV) {
2348 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
2349 $saw_ignore_profile = 1;
2352 # note: this must come before -pro and -profile, below:
2353 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
2354 $saw_dump_profile = 1;
2356 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
2359 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
2364 # resolve <dir>/.../<file>, meaning look upwards from directory
2365 if ( defined($config_file) ) {
2366 if ( my ( $start_dir, $search_file ) =
2367 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
2369 $start_dir = '.' if !$start_dir;
2370 $start_dir = Cwd::realpath($start_dir);
2371 if ( my $found_file =
2372 find_file_upwards( $start_dir, $search_file ) )
2374 $config_file = $found_file;
2378 unless ( -e $config_file ) {
2379 Warn("cannot find file given with -pro=$config_file: $!\n");
2383 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
2384 Die("usage: -pro=filename or --profile=filename, no spaces\n");
2386 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
2390 elsif ( $i =~ /^-(version|v)$/ ) {
2394 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
2395 dump_defaults( @{$rdefaults} );
2398 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
2399 dump_long_names( @{$roption_string} );
2402 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
2403 dump_short_names($rexpansion);
2406 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
2407 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
2412 if ( $saw_dump_profile && $saw_ignore_profile ) {
2413 Warn("No profile to dump because of -npro\n");
2417 #---------------------------------------------------------------
2418 # read any .perltidyrc configuration file
2419 #---------------------------------------------------------------
2420 unless ($saw_ignore_profile) {
2422 # resolve possible conflict between $perltidyrc_stream passed
2423 # as call parameter to perltidy and -pro=filename on command
2425 if ($perltidyrc_stream) {
2428 Conflict: a perltidyrc configuration file was specified both as this
2429 perltidy call parameter: $perltidyrc_stream
2430 and with this -profile=$config_file.
2431 Using -profile=$config_file.
2435 $config_file = $perltidyrc_stream;
2439 # look for a config file if we don't have one yet
2440 my $rconfig_file_chatter;
2441 ${$rconfig_file_chatter} = "";
2443 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
2444 $rpending_complaint )
2445 unless $config_file;
2447 # open any config file
2450 ( $fh_config, $config_file ) =
2451 Perl::Tidy::streamhandle( $config_file, 'r' );
2452 unless ($fh_config) {
2453 ${$rconfig_file_chatter} .=
2454 "# $config_file exists but cannot be opened\n";
2458 if ($saw_dump_profile) {
2459 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
2465 my ( $rconfig_list, $death_message ) =
2466 read_config_file( $fh_config, $config_file, $rexpansion );
2467 Die($death_message) if ($death_message);
2469 # process any .perltidyrc parameters right now so we can
2471 if ( @{$rconfig_list} ) {
2472 local @ARGV = @{$rconfig_list};
2474 expand_command_abbreviations( $rexpansion, \@raw_options,
2477 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2479 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
2483 # Anything left in this local @ARGV is an error and must be
2484 # invalid bare words from the configuration file. We cannot
2485 # check this earlier because bare words may have been valid
2486 # values for parameters. We had to wait for GetOptions to have
2490 my $str = "\'" . pop(@ARGV) . "\'";
2491 while ( my $param = pop(@ARGV) ) {
2492 if ( length($str) < 70 ) {
2493 $str .= ", '$param'";
2501 There are $count unrecognized values in the configuration file '$config_file':
2503 Use leading dashes for parameters. Use -npro to ignore this file.
2507 # Undo any options which cause premature exit. They are not
2508 # appropriate for a config file, and it could be hard to
2509 # diagnose the cause of the premature exit.
2512 dump-cuddled-block-list
2519 dump-want-left-space
2520 dump-want-right-space
2528 if ( defined( $Opts{$_} ) ) {
2530 Warn("ignoring --$_ in config file: $config_file\n");
2537 #---------------------------------------------------------------
2538 # now process the command line parameters
2539 #---------------------------------------------------------------
2540 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
2542 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
2543 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
2544 Die("Error on command line; for help try 'perltidy -h'\n");
2547 # reset Getopt::Long configuration back to its previous value
2548 eval { Getopt::Long::Configure($glc) } if defined $glc;
2550 return ( \%Opts, $config_file, \@raw_options, $roption_string,
2551 $rexpansion, $roption_category, $roption_range );
2552 } # end of _process_command_line
2556 my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
2558 #---------------------------------------------------------------
2559 # check and handle any interactions among the basic options..
2560 #---------------------------------------------------------------
2562 # Since -vt, -vtc, and -cti are abbreviations, but under
2563 # msdos, an unquoted input parameter like vtc=1 will be
2564 # seen as 2 parameters, vtc and 1, so the abbreviations
2565 # won't be seen. Therefore, we will catch them here if
2568 if ( defined $rOpts->{'vertical-tightness'} ) {
2569 my $vt = $rOpts->{'vertical-tightness'};
2570 $rOpts->{'paren-vertical-tightness'} = $vt;
2571 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
2572 $rOpts->{'brace-vertical-tightness'} = $vt;
2575 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
2576 my $vtc = $rOpts->{'vertical-tightness-closing'};
2577 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
2578 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
2579 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
2582 if ( defined $rOpts->{'closing-token-indentation'} ) {
2583 my $cti = $rOpts->{'closing-token-indentation'};
2584 $rOpts->{'closing-square-bracket-indentation'} = $cti;
2585 $rOpts->{'closing-brace-indentation'} = $cti;
2586 $rOpts->{'closing-paren-indentation'} = $cti;
2589 # In quiet mode, there is no log file and hence no way to report
2590 # results of syntax check, so don't do it.
2591 if ( $rOpts->{'quiet'} ) {
2592 $rOpts->{'check-syntax'} = 0;
2595 # can't check syntax if no output
2596 if ( $rOpts->{'format'} ne 'tidy' ) {
2597 $rOpts->{'check-syntax'} = 0;
2600 # Never let Windows 9x/Me systems run syntax check -- this will prevent a
2601 # wide variety of nasty problems on these systems, because they cannot
2602 # reliably run backticks. Don't even think about changing this!
2603 if ( $rOpts->{'check-syntax'}
2605 && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
2607 $rOpts->{'check-syntax'} = 0;
2610 # Added Dec 2017: Deactivating check-syntax for all systems for safety
2611 # because unexpected results can occur when code in BEGIN blocks is
2612 # executed. This flag was included to help check for perltidy mistakes,
2613 # and may still be useful for debugging. To activate for testing comment
2614 # out the next three lines.
2616 $rOpts->{'check-syntax'} = 0;
2619 # It's really a bad idea to check syntax as root unless you wrote
2620 # the script yourself. FIXME: not sure if this works with VMS
2621 unless ($is_Windows) {
2623 if ( $< == 0 && $rOpts->{'check-syntax'} ) {
2624 $rOpts->{'check-syntax'} = 0;
2625 ${$rpending_complaint} .=
2626 "Syntax check deactivated for safety; you shouldn't run this as root\n";
2630 # check iteration count and quietly fix if necessary:
2631 # - iterations option only applies to code beautification mode
2632 # - the convergence check should stop most runs on iteration 2, and
2633 # virtually all on iteration 3. But we'll allow up to 6.
2634 if ( $rOpts->{'format'} ne 'tidy' ) {
2635 $rOpts->{'iterations'} = 1;
2637 elsif ( defined( $rOpts->{'iterations'} ) ) {
2638 if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
2639 elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 }
2642 $rOpts->{'iterations'} = 1;
2645 my $check_blank_count = sub {
2646 my ( $key, $abbrev ) = @_;
2647 if ( $rOpts->{$key} ) {
2648 if ( $rOpts->{$key} < 0 ) {
2650 Warn("negative value of $abbrev, setting 0\n");
2652 if ( $rOpts->{$key} > 100 ) {
2653 Warn("unreasonably large value of $abbrev, reducing\n");
2654 $rOpts->{$key} = 100;
2659 # check for reasonable number of blank lines and fix to avoid problems
2660 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
2661 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
2662 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
2663 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
2665 # setting a non-negative logfile gap causes logfile to be saved
2666 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
2667 $rOpts->{'logfile'} = 1;
2670 # set short-cut flag when only indentation is to be done.
2671 # Note that the user may or may not have already set the
2673 if ( !$rOpts->{'add-whitespace'}
2674 && !$rOpts->{'delete-old-whitespace'}
2675 && !$rOpts->{'add-newlines'}
2676 && !$rOpts->{'delete-old-newlines'} )
2678 $rOpts->{'indent-only'} = 1;
2681 # -isbc implies -ibc
2682 if ( $rOpts->{'indent-spaced-block-comments'} ) {
2683 $rOpts->{'indent-block-comments'} = 1;
2686 # -bli flag implies -bl
2687 if ( $rOpts->{'brace-left-and-indent'} ) {
2688 $rOpts->{'opening-brace-on-new-line'} = 1;
2691 if ( $rOpts->{'opening-brace-always-on-right'}
2692 && $rOpts->{'opening-brace-on-new-line'} )
2695 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
2696 'opening-brace-on-new-line' (-bl). Ignoring -bl.
2698 $rOpts->{'opening-brace-on-new-line'} = 0;
2701 # it simplifies things if -bl is 0 rather than undefined
2702 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
2703 $rOpts->{'opening-brace-on-new-line'} = 0;
2706 # -sbl defaults to -bl if not defined
2707 if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
2708 $rOpts->{'opening-sub-brace-on-new-line'} =
2709 $rOpts->{'opening-brace-on-new-line'};
2712 if ( $rOpts->{'entab-leading-whitespace'} ) {
2713 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
2714 Warn("-et=n must use a positive integer; ignoring -et\n");
2715 $rOpts->{'entab-leading-whitespace'} = undef;
2718 # entab leading whitespace has priority over the older 'tabs' option
2719 if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
2722 # set a default tabsize to be used in guessing the starting indentation
2723 # level if and only if this run does not use tabs and the old code does
2725 if ( $rOpts->{'default-tabsize'} ) {
2726 if ( $rOpts->{'default-tabsize'} < 0 ) {
2727 Warn("negative value of -dt, setting 0\n");
2728 $rOpts->{'default-tabsize'} = 0;
2730 if ( $rOpts->{'default-tabsize'} > 20 ) {
2731 Warn("unreasonably large value of -dt, reducing\n");
2732 $rOpts->{'default-tabsize'} = 20;
2736 $rOpts->{'default-tabsize'} = 8;
2739 # Define $tabsize, the number of spaces per tab for use in
2740 # guessing the indentation of source lines with leading tabs.
2741 # Assume same as for this run if tabs are used , otherwise assume
2742 # a default value, typically 8
2744 $rOpts->{'entab-leading-whitespace'}
2745 ? $rOpts->{'entab-leading-whitespace'}
2746 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
2747 : $rOpts->{'default-tabsize'};
2751 sub find_file_upwards {
2752 my ( $search_dir, $search_file ) = @_;
2754 $search_dir =~ s{/+$}{};
2755 $search_file =~ s{^/+}{};
2758 my $try_path = "$search_dir/$search_file";
2759 if ( -f $try_path ) {
2762 elsif ( $search_dir eq '/' ) {
2766 $search_dir = dirname($search_dir);
2770 # This return is for Perl-Critic.
2771 # We shouldn't get out of the while loop without a return
2775 sub expand_command_abbreviations {
2777 # go through @ARGV and expand any abbreviations
2779 my ( $rexpansion, $rraw_options, $config_file ) = @_;
2781 # set a pass limit to prevent an infinite loop;
2782 # 10 should be plenty, but it may be increased to allow deeply
2783 # nested expansions.
2784 my $max_passes = 10;
2787 # keep looping until all expansions have been converted into actual
2789 foreach my $pass_count ( 0 .. $max_passes ) {
2791 my $abbrev_count = 0;
2793 # loop over each item in @ARGV..
2794 foreach my $word (@ARGV) {
2796 # convert any leading 'no-' to just 'no'
2797 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
2799 # if it is a dash flag (instead of a file name)..
2800 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
2805 # save the raw input for debug output in case of circular refs
2806 if ( $pass_count == 0 ) {
2807 push( @{$rraw_options}, $word );
2810 # recombine abbreviation and flag, if necessary,
2811 # to allow abbreviations with arguments such as '-vt=1'
2812 if ( $rexpansion->{ $abr . $flags } ) {
2813 $abr = $abr . $flags;
2817 # if we see this dash item in the expansion hash..
2818 if ( $rexpansion->{$abr} ) {
2821 # stuff all of the words that it expands to into the
2822 # new arg list for the next pass
2823 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
2824 next unless $abbrev; # for safety; shouldn't happen
2825 push( @new_argv, '--' . $abbrev . $flags );
2829 # not in expansion hash, must be actual long name
2831 push( @new_argv, $word );
2835 # not a dash item, so just save it for the next pass
2837 push( @new_argv, $word );
2839 } # end of this pass
2841 # update parameter list @ARGV to the new one
2843 last unless ( $abbrev_count > 0 );
2845 # make sure we are not in an infinite loop
2846 if ( $pass_count == $max_passes ) {
2849 I'm tired. We seem to be in an infinite loop trying to expand aliases.
2850 Here are the raw options;
2853 my $num = @new_argv;
2856 After $max_passes passes here is ARGV
2862 After $max_passes passes ARGV has $num entries
2868 Please check your configuration file $config_file for circular-references.
2869 To deactivate it, use -npro.
2874 Program bug - circular-references in the %expansion hash, probably due to
2875 a recent program change.
2878 } # end of check for circular references
2879 } # end of loop over all passes
2883 # Debug routine -- this will dump the expansion hash
2884 sub dump_short_names {
2885 my $rexpansion = shift;
2887 List of short names. This list shows how all abbreviations are
2888 translated into other abbreviations and, eventually, into long names.
2889 New abbreviations may be defined in a .perltidyrc file.
2890 For a list of all long names, use perltidy --dump-long-names (-dln).
2891 --------------------------------------------------------------------------
2893 foreach my $abbrev ( sort keys %$rexpansion ) {
2894 my @list = @{ $rexpansion->{$abbrev} };
2895 print STDOUT "$abbrev --> @list\n";
2900 sub check_vms_filename {
2902 # given a valid filename (the perltidy input file)
2903 # create a modified filename and separator character
2906 # Contributed by Michael Cartmell
2908 my $filename = shift;
2909 my ( $base, $path ) = fileparse($filename);
2911 # remove explicit ; version
2912 $base =~ s/;-?\d*$//
2914 # remove explicit . version ie two dots in filename NB ^ escapes a dot
2915 or $base =~ s/( # begin capture $1
2916 (?:^|[^^])\. # match a dot not preceded by a caret
2917 (?: # followed by nothing
2919 .*[^^] # anything ending in a non caret
2922 \.-?\d*$ # match . version number
2925 # normalise filename, if there are no unescaped dots then append one
2926 $base .= '.' unless $base =~ /(?:^|[^^])\./;
2928 # if we don't already have an extension then we just append the extension
2929 my $separator = ( $base =~ /\.$/ ) ? "" : "_";
2930 return ( $path . $base, $separator );
2935 # TODO: are these more standard names?
2936 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
2938 # Returns a string that determines what MS OS we are on.
2939 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
2940 # Returns blank string if not an MS system.
2941 # Original code contributed by: Yves Orton
2942 # We need to know this to decide where to look for config files
2944 my $rpending_complaint = shift;
2946 return $os unless $^O =~ /win32|dos/i; # is it a MS box?
2948 # Systems built from Perl source may not have Win32.pm
2949 # But probably have Win32::GetOSVersion() anyway so the
2950 # following line is not 'required':
2951 # return $os unless eval('require Win32');
2953 # Use the standard API call to determine the version
2954 my ( $undef, $major, $minor, $build, $id );
2955 eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
2958 # NAME ID MAJOR MINOR
2959 # Windows NT 4 2 4 0
2960 # Windows 2000 2 5 0
2962 # Windows Server 2003 2 5 2
2964 return "win32s" unless $id; # If id==0 then its a win32s box.
2965 $os = { # Magic numbers from MSDN
2966 # documentation of GetOSVersion
2973 0 => "2000", # or NT 4, see below
2980 # If $os is undefined, the above code is out of date. Suggested updates
2982 unless ( defined $os ) {
2985 # Deactivated this message 20180322 because it was needlessly
2986 # causing some test scripts to fail. Need help from someone
2987 # with expertise in Windows to decide what is possible with windows.
2988 ${$rpending_complaint} .= <<EOS if (0);
2989 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
2990 We won't be able to look for a system-wide config file.
2994 # Unfortunately the logic used for the various versions isn't so clever..
2995 # so we have to handle an outside case.
2996 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
3001 ( $^O !~ /win32|dos/i )
3004 && ( $^O ne 'MacOS' );
3007 sub look_for_Windows {
3009 # determine Windows sub-type and location of
3010 # system-wide configuration files
3011 my $rpending_complaint = shift;
3012 my $is_Windows = ( $^O =~ /win32|dos/i );
3014 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
3015 return ( $is_Windows, $Windows_type );
3018 sub find_config_file {
3020 # look for a .perltidyrc configuration file
3021 # For Windows also look for a file named perltidy.ini
3022 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
3023 $rpending_complaint ) = @_;
3025 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
3027 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
3030 ${$rconfig_file_chatter} .= " $^O\n";
3033 # sub to check file existence and record all tests
3034 my $exists_config_file = sub {
3035 my $config_file = shift;
3036 return 0 unless $config_file;
3037 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
3038 return -f $config_file;
3041 # Sub to search upward for config file
3042 my $resolve_config_file = sub {
3044 # resolve <dir>/.../<file>, meaning look upwards from directory
3045 my $config_file = shift;
3047 if ( my ( $start_dir, $search_file ) =
3048 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3050 ${$rconfig_file_chatter} .=
3051 "# Searching Upward: $config_file\n";
3052 $start_dir = '.' if !$start_dir;
3053 $start_dir = Cwd::realpath($start_dir);
3054 if ( my $found_file =
3055 find_file_upwards( $start_dir, $search_file ) )
3057 $config_file = $found_file;
3058 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
3062 return $config_file;
3067 # look in current directory first
3068 $config_file = ".perltidyrc";
3069 return $config_file if $exists_config_file->($config_file);
3071 $config_file = "perltidy.ini";
3072 return $config_file if $exists_config_file->($config_file);
3075 # Default environment vars.
3076 my @envs = qw(PERLTIDY HOME);
3078 # Check the NT/2k/XP locations, first a local machine def, then a
3080 push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
3082 # Now go through the environment ...
3083 foreach my $var (@envs) {
3084 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
3085 if ( defined( $ENV{$var} ) ) {
3086 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
3088 # test ENV{ PERLTIDY } as file:
3089 if ( $var eq 'PERLTIDY' ) {
3090 $config_file = "$ENV{$var}";
3091 $config_file = $resolve_config_file->($config_file);
3092 return $config_file if $exists_config_file->($config_file);
3095 # test ENV as directory:
3096 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
3097 $config_file = $resolve_config_file->($config_file);
3098 return $config_file if $exists_config_file->($config_file);
3101 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
3102 $config_file = $resolve_config_file->($config_file);
3103 return $config_file if $exists_config_file->($config_file);
3107 ${$rconfig_file_chatter} .= "\n";
3111 # then look for a system-wide definition
3112 # where to look varies with OS
3115 if ($Windows_type) {
3116 my ( $os, $system, $allusers ) =
3117 Win_Config_Locs( $rpending_complaint, $Windows_type );
3119 # Check All Users directory, if there is one.
3120 # i.e. C:\Documents and Settings\User\perltidy.ini
3123 $config_file = catfile( $allusers, ".perltidyrc" );
3124 return $config_file if $exists_config_file->($config_file);
3126 $config_file = catfile( $allusers, "perltidy.ini" );
3127 return $config_file if $exists_config_file->($config_file);
3130 # Check system directory.
3131 # retain old code in case someone has been able to create
3132 # a file with a leading period.
3133 $config_file = catfile( $system, ".perltidyrc" );
3134 return $config_file if $exists_config_file->($config_file);
3136 $config_file = catfile( $system, "perltidy.ini" );
3137 return $config_file if $exists_config_file->($config_file);
3141 # Place to add customization code for other systems
3142 elsif ( $^O eq 'OS2' ) {
3144 elsif ( $^O eq 'MacOS' ) {
3146 elsif ( $^O eq 'VMS' ) {
3149 # Assume some kind of Unix
3152 $config_file = "/usr/local/etc/perltidyrc";
3153 return $config_file if $exists_config_file->($config_file);
3155 $config_file = "/etc/perltidyrc";
3156 return $config_file if $exists_config_file->($config_file);
3159 # Couldn't find a config file
3163 sub Win_Config_Locs {
3165 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
3166 # or undef if its not a win32 OS. In list context returns OS, System
3167 # Directory, and All Users Directory. All Users will be empty on a
3168 # 9x/Me box. Contributed by: Yves Orton.
3171 # my $rpending_complaint = shift;
3172 # my $os = (@_) ? shift : Win_OS_Type();
3174 my ( $rpending_complaint, $os ) = @_;
3175 if ( !$os ) { $os = Win_OS_Type(); }
3182 if ( $os =~ /9[58]|Me/ ) {
3183 $system = "C:/Windows";
3185 elsif ( $os =~ /NT|XP|200?/ ) {
3186 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
3189 ? "C:/WinNT/profiles/All Users/"
3190 : "C:/Documents and Settings/All Users/";
3194 # This currently would only happen on a win32s computer. I don't have
3195 # one to test, so I am unsure how to proceed. Suggestions welcome!
3196 ${$rpending_complaint} .=
3197 "I dont know a sensible place to look for config files on an $os system.\n";
3200 return wantarray ? ( $os, $system, $allusers ) : $os;
3203 sub dump_config_file {
3204 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
3205 print STDOUT "$$rconfig_file_chatter";
3207 print STDOUT "# Dump of file: '$config_file'\n";
3208 while ( my $line = $fh->getline() ) { print STDOUT $line }
3209 eval { $fh->close() };
3212 print STDOUT "# ...no config file found\n";
3217 sub read_config_file {
3219 my ( $fh, $config_file, $rexpansion ) = @_;
3220 my @config_list = ();
3222 # file is bad if non-empty $death_message is returned
3223 my $death_message = "";
3227 my $opening_brace_line;
3228 while ( my $line = $fh->getline() ) {
3231 ( $line, $death_message ) =
3232 strip_comment( $line, $config_file, $line_no );
3233 last if ($death_message);
3235 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
3240 # Look for complete or partial abbreviation definition of the form
3241 # name { body } or name { or name { body
3242 # See rules in perltidy's perldoc page
3243 # Section: Other Controls - Creating a new abbreviation
3244 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
3245 my $oldname = $name;
3246 ( $name, $body ) = ( $2, $3 );
3248 # Cannot start new abbreviation unless old abbreviation is complete
3249 last if ($opening_brace_line);
3251 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
3253 # handle a new alias definition
3254 if ( ${$rexpansion}{$name} ) {
3256 my @names = sort keys %$rexpansion;
3258 "Here is a list of all installed aliases\n(@names)\n"
3259 . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
3262 ${$rexpansion}{$name} = [];
3265 # leading opening braces not allowed
3266 elsif ( $line =~ /^{/ ) {
3267 $opening_brace_line = undef;
3269 "Unexpected '{' at line $line_no in config file '$config_file'\n";
3273 # Look for abbreviation closing: body } or }
3274 elsif ( $line =~ /^(.*)?\}$/ ) {
3276 if ($opening_brace_line) {
3277 $opening_brace_line = undef;
3281 "Unexpected '}' at line $line_no in config file '$config_file'\n";
3286 # Now store any parameters
3289 my ( $rbody_parts, $msg ) = parse_args($body);
3291 $death_message = <<EOM;
3292 Error reading file '$config_file' at line number $line_no.
3294 Please fix this line or use -npro to avoid reading this file
3301 # remove leading dashes if this is an alias
3302 foreach ( @{$rbody_parts} ) { s/^\-+//; }
3303 push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
3306 push( @config_list, @{$rbody_parts} );
3311 if ($opening_brace_line) {
3313 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
3315 eval { $fh->close() };
3316 return ( \@config_list, $death_message );
3321 # Strip any comment from a command line
3322 my ( $instr, $config_file, $line_no ) = @_;
3325 # check for full-line comment
3326 if ( $instr =~ /^\s*#/ ) {
3327 return ( "", $msg );
3330 # nothing to do if no comments
3331 if ( $instr !~ /#/ ) {
3332 return ( $instr, $msg );
3335 # handle case of no quotes
3336 elsif ( $instr !~ /['"]/ ) {
3338 # We now require a space before the # of a side comment
3339 # this allows something like:
3341 # Otherwise, it would have to be quoted:
3343 $instr =~ s/\s+\#.*$//;
3344 return ( $instr, $msg );
3347 # handle comments and quotes
3349 my $quote_char = "";
3352 # looking for ending quote character
3354 if ( $instr =~ /\G($quote_char)/gc ) {
3358 elsif ( $instr =~ /\G(.)/gc ) {
3362 # error..we reached the end without seeing the ending quote char
3365 Error reading file $config_file at line number $line_no.
3366 Did not see ending quote character <$quote_char> in this text:
3368 Please fix this line or use -npro to avoid reading this file
3374 # accumulating characters and looking for start of a quoted string
3376 if ( $instr =~ /\G([\"\'])/gc ) {
3381 # Note: not yet enforcing the space-before-hash rule for side
3382 # comments if the parameter is quoted.
3383 elsif ( $instr =~ /\G#/gc ) {
3386 elsif ( $instr =~ /\G(.)/gc ) {
3394 return ( $outstr, $msg );
3399 # Parse a command string containing multiple string with possible
3400 # quotes, into individual commands. It might look like this, for example:
3402 # -wba=" + - " -some-thing -wbb='. && ||'
3404 # There is no need, at present, to handle escaped quote characters.
3405 # (They are not perltidy tokens, so needn't be in strings).
3408 my @body_parts = ();
3409 my $quote_char = "";
3414 # looking for ending quote character
3416 if ( $body =~ /\G($quote_char)/gc ) {
3419 elsif ( $body =~ /\G(.)/gc ) {
3423 # error..we reached the end without seeing the ending quote char
3425 if ( length($part) ) { push @body_parts, $part; }
3427 Did not see ending quote character <$quote_char> in this text:
3434 # accumulating characters and looking for start of a quoted string
3436 if ( $body =~ /\G([\"\'])/gc ) {
3439 elsif ( $body =~ /\G(\s+)/gc ) {
3440 if ( length($part) ) { push @body_parts, $part; }
3443 elsif ( $body =~ /\G(.)/gc ) {
3447 if ( length($part) ) { push @body_parts, $part; }
3452 return ( \@body_parts, $msg );
3455 sub dump_long_names {
3459 # Command line long names (passed to GetOptions)
3460 #---------------------------------------------------------------
3461 # here is a summary of the Getopt codes:
3462 # <none> does not take an argument
3463 # =s takes a mandatory string
3464 # :s takes an optional string
3465 # =i takes a mandatory integer
3466 # :i takes an optional integer
3467 # ! does not take an argument and may be negated
3468 # i.e., -foo and -nofoo are allowed
3469 # a double dash signals the end of the options list
3471 #---------------------------------------------------------------
3474 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
3480 print STDOUT "Default command line options:\n";
3481 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
3485 sub readable_options {
3487 # return options for this run as a string which could be
3488 # put in a perltidyrc file
3489 my ( $rOpts, $roption_string ) = @_;
3491 my $rGetopt_flags = \%Getopt_flags;
3492 my $readable_options = "# Final parameter set for this run.\n";
3493 $readable_options .=
3494 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
3495 foreach my $opt ( @{$roption_string} ) {
3497 if ( $opt =~ /(.*)(!|=.*)$/ ) {
3501 if ( defined( $rOpts->{$opt} ) ) {
3502 $rGetopt_flags->{$opt} = $flag;
3505 foreach my $key ( sort keys %{$rOpts} ) {
3506 my $flag = $rGetopt_flags->{$key};
3507 my $value = $rOpts->{$key};
3511 if ( $flag =~ /^=/ ) {
3512 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
3513 $suffix = "=" . $value;
3515 elsif ( $flag =~ /^!/ ) {
3516 $prefix .= "no" unless ($value);
3521 $readable_options .=
3522 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
3525 $readable_options .= $prefix . $key . $suffix . "\n";
3527 return $readable_options;
3531 print STDOUT <<"EOM";
3532 This is perltidy, v$VERSION
3534 Copyright 2000-2018, Steve Hancock
3536 Perltidy is free software and may be copied under the terms of the GNU
3537 General Public License, which is included in the distribution files.
3539 Complete documentation for perltidy can be found using 'man perltidy'
3540 or on the internet at http://perltidy.sourceforge.net.
3548 This is perltidy version $VERSION, a perl script indenter. Usage:
3550 perltidy [ options ] file1 file2 file3 ...
3551 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
3552 perltidy [ options ] file1 -o outfile
3553 perltidy [ options ] file1 -st >outfile
3554 perltidy [ options ] <infile >outfile
3556 Options have short and long forms. Short forms are shown; see
3557 man pages for long forms. Note: '=s' indicates a required string,
3558 and '=n' indicates a required integer.
3562 -o=file name of the output file (only if single input file)
3563 -oext=s change output extension from 'tdy' to s
3564 -opath=path change path to be 'path' for output files
3565 -b backup original to .bak and modify file in-place
3566 -bext=s change default backup extension from 'bak' to s
3567 -q deactivate error messages (for running under editor)
3568 -w include non-critical warning messages in the .ERR error output
3569 -syn run perl -c to check syntax (default under unix systems)
3570 -log save .LOG file, which has useful diagnostics
3571 -f force perltidy to read a binary file
3572 -g like -log but writes more detailed .LOG file, for debugging scripts
3573 -opt write the set of options actually used to a .LOG file
3574 -npro ignore .perltidyrc configuration command file
3575 -pro=file read configuration commands from file instead of .perltidyrc
3576 -st send output to standard output, STDOUT
3577 -se send all error output to standard error output, STDERR
3578 -v display version number to standard output and quit
3581 -i=n use n columns per indentation level (default n=4)
3582 -t tabs: use one tab character per indentation level, not recommeded
3583 -nt no tabs: use n spaces per indentation level (default)
3584 -et=n entab leading whitespace n spaces per tab; not recommended
3585 -io "indent only": just do indentation, no other formatting.
3586 -sil=n set starting indentation level to n; use if auto detection fails
3587 -ole=s specify output line ending (s=dos or win, mac, unix)
3588 -ple keep output line endings same as input (input must be filename)
3591 -fws freeze whitespace; this disables all whitespace changes
3592 and disables the following switches:
3593 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
3594 -bbt same as -bt but for code block braces; same as -bt if not given
3595 -bbvt block braces vertically tight; use with -bl or -bli
3596 -bbvtl=s make -bbvt to apply to selected list of block types
3597 -pt=n paren tightness (n=0, 1 or 2)
3598 -sbt=n square bracket tightness (n=0, 1, or 2)
3599 -bvt=n brace vertical tightness,
3600 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
3601 -pvt=n paren vertical tightness (see -bvt for n)
3602 -sbvt=n square bracket vertical tightness (see -bvt for n)
3603 -bvtc=n closing brace vertical tightness:
3604 n=(0=open, 1=sometimes close, 2=always close)
3605 -pvtc=n closing paren vertical tightness, see -bvtc for n.
3606 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
3607 -ci=n sets continuation indentation=n, default is n=2 spaces
3608 -lp line up parentheses, brackets, and non-BLOCK braces
3609 -sfs add space before semicolon in for( ; ; )
3610 -aws allow perltidy to add whitespace (default)
3611 -dws delete all old non-essential whitespace
3612 -icb indent closing brace of a code block
3613 -cti=n closing indentation of paren, square bracket, or non-block brace:
3614 n=0 none, =1 align with opening, =2 one full indentation level
3615 -icp equivalent to -cti=2
3616 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
3617 -wrs=s want space right of tokens in string;
3618 -sts put space before terminal semicolon of a statement
3619 -sak=s put space between keywords given in s and '(';
3620 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
3623 -fnl freeze newlines; this disables all line break changes
3624 and disables the following switches:
3625 -anl add newlines; ok to introduce new line breaks
3626 -bbs add blank line before subs and packages
3627 -bbc add blank line before block comments
3628 -bbb add blank line between major blocks
3629 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
3630 -mbl=n maximum consecutive blank lines to output (default=1)
3631 -ce cuddled else; use this style: '} else {'
3632 -cb cuddled blocks (other than 'if-elsif-else')
3633 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
3634 -dnl delete old newlines (default)
3635 -l=n maximum line length; default n=80
3636 -bl opening brace on new line
3637 -sbl opening sub brace on new line. value of -bl is used if not given.
3638 -bli opening brace on new line and indented
3639 -bar opening brace always on right, even for long clauses
3640 -vt=n vertical tightness (requires -lp); n controls break after opening
3641 token: 0=never 1=no break if next line balanced 2=no break
3642 -vtc=n vertical tightness of closing container; n controls if closing
3643 token starts new line: 0=always 1=not unless list 1=never
3644 -wba=s want break after tokens in string; i.e. wba=': .'
3645 -wbb=s want break before tokens in string
3646 -wn weld nested: combines opening and closing tokens when both are adjacent
3648 Following Old Breakpoints
3649 -kis keep interior semicolons. Allows multiple statements per line.
3650 -boc break at old comma breaks: turns off all automatic list formatting
3651 -bol break at old logical breakpoints: or, and, ||, && (default)
3652 -bok break at old list keyword breakpoints such as map, sort (default)
3653 -bot break at old conditional (ternary ?:) operator breakpoints (default)
3654 -boa break at old attribute breakpoints
3655 -cab=n break at commas after a comma-arrow (=>):
3656 n=0 break at all commas after =>
3657 n=1 stable: break unless this breaks an existing one-line container
3658 n=2 break only if a one-line container cannot be formed
3659 n=3 do not treat commas after => specially at all
3662 -ibc indent block comments (default)
3663 -isbc indent spaced block comments; may indent unless no leading space
3664 -msc=n minimum desired spaces to side comment, default 4
3665 -fpsc=n fix position for side comments; default 0;
3666 -csc add or update closing side comments after closing BLOCK brace
3667 -dcsc delete closing side comments created by a -csc command
3668 -cscp=s change closing side comment prefix to be other than '## end'
3669 -cscl=s change closing side comment to apply to selected list of blocks
3670 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
3671 -csct=n maximum number of columns of appended text, default n=20
3672 -cscw causes warning if old side comment is overwritten with -csc
3674 -sbc use 'static block comments' identified by leading '##' (default)
3675 -sbcp=s change static block comment identifier to be other than '##'
3676 -osbc outdent static block comments
3678 -ssc use 'static side comments' identified by leading '##' (default)
3679 -sscp=s change static side comment identifier to be other than '##'
3681 Delete selected text
3682 -dac delete all comments AND pod
3683 -dbc delete block comments
3684 -dsc delete side comments
3687 Send selected text to a '.TEE' file
3688 -tac tee all comments AND pod
3689 -tbc tee block comments
3690 -tsc tee side comments
3694 -olq outdent long quoted strings (default)
3695 -olc outdent a long block comment line
3696 -ola outdent statement labels
3697 -okw outdent control keywords (redo, next, last, goto, return)
3698 -okwl=s specify alternative keywords for -okw command
3701 -mft=n maximum fields per table; default n=40
3702 -x do not format lines before hash-bang line (i.e., for VMS)
3703 -asc allows perltidy to add a ';' when missing (default)
3704 -dsm allows perltidy to delete an unnecessary ';' (default)
3706 Combinations of other parameters
3707 -gnu attempt to follow GNU Coding Standards as applied to perl
3708 -mangle remove as many newlines as possible (but keep comments and pods)
3709 -extrude insert as many newlines as possible
3711 Dump and die, debugging
3712 -dop dump options used in this run to standard output and quit
3713 -ddf dump default options to standard output and quit
3714 -dsn dump all option short names to standard output and quit
3715 -dln dump option long names to standard output and quit
3716 -dpro dump whatever configuration file is in effect to standard output
3717 -dtt dump all token types to standard output and quit
3720 -html write an html file (see 'man perl2web' for many options)
3721 Note: when -html is used, no indentation or formatting are done.
3722 Hint: try perltidy -html -css=mystyle.css filename.pl
3723 and edit mystyle.css to change the appearance of filename.html.
3724 -nnn gives line numbers
3725 -pre only writes out <pre>..</pre> code section
3726 -toc places a table of contents to subs at the top (default)
3727 -pod passes pod text through pod2html (default)
3728 -frm write html as a frame (3 files)
3729 -text=s extra extension for table of contents if -frm, default='toc'
3730 -sext=s extra extension for file content if -frm, default='src'
3732 A prefix of "n" negates short form toggle switches, and a prefix of "no"
3733 negates the long forms. For example, -nasc means don't add missing
3736 If you are unable to see this entire text, try "perltidy -h | more"
3737 For more detailed information, and additional options, try "man perltidy",
3738 or go to the perltidy home page at http://perltidy.sourceforge.net
3744 sub process_this_file {
3746 my ( $tokenizer, $formatter ) = @_;
3748 while ( my $line = $tokenizer->get_line() ) {
3749 $formatter->write_line($line);
3751 my $severe_error = $tokenizer->report_tokenization_errors();
3752 eval { $formatter->finish_formatting($severe_error) };
3759 # Use 'perl -c' to make sure that we did not create bad syntax
3760 # This is a very good independent check for programming errors
3762 # Given names of the input and output files, ($istream, $ostream),
3763 # we do the following:
3764 # - check syntax of the input file
3765 # - if bad, all done (could be an incomplete code snippet)
3766 # - if infile syntax ok, then check syntax of the output file;
3767 # - if outfile syntax bad, issue warning; this implies a code bug!
3768 # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
3770 my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
3771 my $infile_syntax_ok = 0;
3772 my $line_of_dashes = '-' x 42 . "\n";
3774 my $flags = $rOpts->{'perl-syntax-check-flags'};
3776 # be sure we invoke perl with -c
3777 # note: perl will accept repeated flags like '-c -c'. It is safest
3778 # to append another -c than try to find an interior bundled c, as
3779 # in -Tc, because such a 'c' might be in a quoted string, for example.
3780 if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
3782 # be sure we invoke perl with -x if requested
3783 # same comments about repeated parameters applies
3784 if ( $rOpts->{'look-for-hash-bang'} ) {
3785 if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
3788 # this shouldn't happen unless a temporary file couldn't be made
3789 if ( $istream eq '-' ) {
3790 $logger_object->write_logfile_entry(
3791 "Cannot run perl -c on STDIN and STDOUT\n");
3792 return $infile_syntax_ok;
3795 $logger_object->write_logfile_entry(
3796 "checking input file syntax with perl $flags\n");
3798 # Not all operating systems/shells support redirection of the standard
3800 my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
3802 my ( $istream_filename, $perl_output ) =
3803 do_syntax_check( $istream, $flags, $error_redirection );
3804 $logger_object->write_logfile_entry(
3805 "Input stream passed to Perl as file $istream_filename\n");
3806 $logger_object->write_logfile_entry($line_of_dashes);
3807 $logger_object->write_logfile_entry("$perl_output\n");
3809 if ( $perl_output =~ /syntax\s*OK/ ) {
3810 $infile_syntax_ok = 1;
3811 $logger_object->write_logfile_entry($line_of_dashes);
3812 $logger_object->write_logfile_entry(
3813 "checking output file syntax with perl $flags ...\n");
3814 my ( $ostream_filename, $perl_output ) =
3815 do_syntax_check( $ostream, $flags, $error_redirection );
3816 $logger_object->write_logfile_entry(
3817 "Output stream passed to Perl as file $ostream_filename\n");
3818 $logger_object->write_logfile_entry($line_of_dashes);
3819 $logger_object->write_logfile_entry("$perl_output\n");
3821 unless ( $perl_output =~ /syntax\s*OK/ ) {
3822 $logger_object->write_logfile_entry($line_of_dashes);
3823 $logger_object->warning(
3824 "The output file has a syntax error when tested with perl $flags $ostream !\n"
3826 $logger_object->warning(
3827 "This implies an error in perltidy; the file $ostream is bad\n"
3829 $logger_object->report_definite_bug();
3831 # the perl version number will be helpful for diagnosing the problem
3832 $logger_object->write_logfile_entry( $^V . "\n" );
3833 ##qx/perl -v $error_redirection/ . "\n" );
3838 # Only warn of perl -c syntax errors. Other messages,
3839 # such as missing modules, are too common. They can be
3840 # seen by running with perltidy -w
3841 $logger_object->complain("A syntax check using perl $flags\n");
3842 $logger_object->complain(
3843 "for the output in file $istream_filename gives:\n");
3844 $logger_object->complain($line_of_dashes);
3845 $logger_object->complain("$perl_output\n");
3846 $logger_object->complain($line_of_dashes);
3847 $infile_syntax_ok = -1;
3848 $logger_object->write_logfile_entry($line_of_dashes);
3849 $logger_object->write_logfile_entry(
3850 "The output file will not be checked because of input file problems\n"
3853 return $infile_syntax_ok;
3856 sub do_syntax_check {
3858 # This should not be called; the syntax check is deactivated
3859 Die("Unexpected call for syntax check-shouldn't happen\n");
3864 sub do_syntax_check {
3865 my ( $stream, $flags, $error_redirection ) = @_;
3867 ############################################################
3868 # This code is not reachable because syntax check is deactivated,
3869 # but it is retained for reference.
3870 ############################################################
3872 # We need a named input file for executing perl
3873 my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
3875 # TODO: Need to add name of file to log somewhere
3876 # otherwise Perl output is hard to read
3877 if ( !$stream_filename ) { return $stream_filename, "" }
3879 # We have to quote the filename in case it has unusual characters
3880 # or spaces. Example: this filename #CM11.pm# gives trouble.
3881 my $quoted_stream_filename = '"' . $stream_filename . '"';
3883 # Under VMS something like -T will become -t (and an error) so we
3884 # will put quotes around the flags. Double quotes seem to work on
3885 # Unix/Windows/VMS, but this may not work on all systems. (Single
3886 # quotes do not work under Windows). It could become necessary to
3887 # put double quotes around each flag, such as: -"c" -"T"
3888 # We may eventually need some system-dependent coding here.
3889 $flags = '"' . $flags . '"';
3891 # now wish for luck...
3892 my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/;
3895 unlink $stream_filename
3896 or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n");
3898 return $stream_filename, $msg;