2 ###########################################################
4 # perltidy - a perl script indenter and formatter
6 # Copyright (c) 2000-2022 by Steve Hancock
7 # Distributed under the GPL license agreement; see file COPYING
9 # This program is free software; you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 2 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License along
20 # with this program; if not, write to the Free Software Foundation, Inc.,
21 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
23 # For brief instructions, try 'perltidy -h'.
24 # For more complete documentation, try 'man perltidy'
25 # or visit http://perltidy.sourceforge.net
27 # This script is an example of the default style. It was formatted with:
31 # Code Contributions: See ChangeLog.html for a complete history.
32 # Michael Cartmell supplied code for adaptation to VMS and helped with
34 # Hugh S. Myers supplied sub streamhandle and the supporting code to
35 # create a Perl::Tidy module which can operate on strings, arrays, etc.
36 # Yves Orton supplied coding to help detect Windows versions.
37 # Axel Rose supplied a patch for MacPerl.
38 # Sebastien Aperghis-Tramoni supplied a patch for the defined or operator.
39 # Dan Tyrell contributed a patch for binary I/O.
40 # Ueli Hugenschmidt contributed a patch for -fpsc
41 # Sam Kington supplied a patch to identify the initial indentation of
43 # jonathan swartz supplied patches for:
44 # * .../ pattern, which looks upwards from directory
45 # * --notidy, to be used in directories where we want to avoid
46 # accidentally tidying
47 # * prefilter and postfilter
50 # Many others have supplied key ideas, suggestions, and bug reports;
51 # see the CHANGES file.
53 ############################################################
57 # perlver reports minimum version needed is 5.8.0
58 # 5.004 needed for IO::File
59 # 5.008 needed for wide characters
65 use English qw( -no_match_vars );
66 use Digest::MD5 qw(md5_hex);
67 use Perl::Tidy::Debugger;
68 use Perl::Tidy::DevNull;
69 use Perl::Tidy::Diagnostics;
70 use Perl::Tidy::FileWriter;
71 use Perl::Tidy::Formatter;
72 use Perl::Tidy::HtmlWriter;
73 use Perl::Tidy::IOScalar;
74 use Perl::Tidy::IOScalarArray;
75 use Perl::Tidy::IndentationItem;
76 use Perl::Tidy::LineSink;
77 use Perl::Tidy::LineSource;
78 use Perl::Tidy::Logger;
79 use Perl::Tidy::Tokenizer;
80 use Perl::Tidy::VerticalAligner;
81 local $OUTPUT_AUTOFLUSH = 1;
83 # DEVEL_MODE can be turned on for extra checking during development
84 use constant DEVEL_MODE => 0;
85 use constant EMPTY_STRING => q{};
86 use constant SPACE => q{ };
94 @ISA = qw( Exporter );
95 @EXPORT = qw( &perltidy );
103 use File::Temp qw(tempfile);
107 # Release version is the approximate YYYYMMDD of the release.
108 # Development version is (Last Release).(Development Number)
110 # To make the number continually increasing, the Development Number is a 2
111 # digit number starting at 01 after a release. It is continually bumped
112 # along at significant points during development. If it ever reaches 99
113 # then the Release version must be bumped, and it is probably past time for
116 $VERSION = '20230309';
121 # required to avoid call to AUTOLOAD in some versions of perl
126 # Catch any undefined sub calls so that we are sure to get
127 # some diagnostic information. This sub should never be called
128 # except for a programming error.
130 return if ( $AUTOLOAD =~ /\bDESTROY$/ );
131 my ( $pkg, $fname, $lno ) = caller();
133 ======================================================================
134 Unexpected call to Autoload looking for sub $AUTOLOAD
135 Called from package: '$pkg'
136 Called from File '$fname' at line '$lno'
137 This error is probably due to a recent programming change
138 ======================================================================
141 } ## end sub AUTOLOAD
145 # given filename and mode (r or w), create an object which:
146 # has a 'getline' method if mode='r', and
147 # has a 'print' method if mode='w'.
148 # The objects also need a 'close' method.
150 # How the object is made:
152 # if $filename is: Make object using:
153 # ---------------- -----------------
154 # '-' (STDIN if mode = 'r', STDOUT if mode='w')
156 # ARRAY ref Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
157 # STRING ref Perl::Tidy::IOScalar (formerly IO::Scalar)
159 # (check for 'print' method for 'w' mode)
160 # (check for 'getline' method for 'r' mode)
162 # An optional flag $is_encoded_data may be given, as follows:
164 # Case 1. Any non-empty string: encoded data is being transferred, set
165 # encoding to be utf8 for files and for stdin.
167 # Case 2. Not given, or an empty string: unencoded binary data is being
168 # transferred, set binary mode for files and for stdin.
170 my ( $filename, $mode, $is_encoded_data ) = @_;
172 my $ref = ref($filename);
178 if ( $ref eq 'ARRAY' ) {
179 $New = sub { Perl::Tidy::IOScalarArray->new( $filename, $mode ) };
181 elsif ( $ref eq 'SCALAR' ) {
182 $New = sub { Perl::Tidy::IOScalar->new( $filename, $mode ) };
186 # Accept an object with a getline method for reading. Note:
187 # IO::File is built-in and does not respond to the defined
188 # operator. If this causes trouble, the check can be
189 # skipped and we can just let it crash if there is no
191 if ( $mode =~ /[rR]/ ) {
193 # RT#97159; part 1 of 2: updated to use 'can'
194 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
195 if ( $ref->can('getline') ) {
196 $New = sub { $filename };
199 $New = sub { undef };
201 ------------------------------------------------------------------------
202 No 'getline' method is defined for object of class '$ref'
203 Please check your call to Perl::Tidy::perltidy. Trace follows.
204 ------------------------------------------------------------------------
209 # Accept an object with a print method for writing.
210 # See note above about IO::File
211 if ( $mode =~ /[wW]/ ) {
213 # RT#97159; part 2 of 2: updated to use 'can'
214 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
215 if ( $ref->can('print') ) {
216 $New = sub { $filename };
219 $New = sub { undef };
221 ------------------------------------------------------------------------
222 No 'print' method is defined for object of class '$ref'
223 Please check your call to Perl::Tidy::perltidy. Trace follows.
224 ------------------------------------------------------------------------
233 if ( $filename eq '-' ) {
234 $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
237 $New = sub { IO::File->new( $filename, $mode ) };
240 $fh = $New->( $filename, $mode );
243 Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n");
248 # Case 1: handle encoded data
249 if ($is_encoded_data) {
250 if ( ref($fh) eq 'IO::File' ) {
251 ## binmode object call not available in older perl versions
252 ## $fh->binmode(":raw:encoding(UTF-8)");
253 binmode $fh, ":raw:encoding(UTF-8)";
255 elsif ( $filename eq '-' ) {
256 binmode STDOUT, ":raw:encoding(UTF-8)";
263 # Case 2: handle unencoded data
265 if ( ref($fh) eq 'IO::File' ) { binmode $fh }
266 elsif ( $filename eq '-' ) { binmode STDOUT }
267 else { } # shouldn't happen
271 return $fh, ( $ref or $filename );
272 } ## end sub streamhandle
274 sub find_input_line_ending {
276 # Peek at a file and return first line ending character.
277 # Return undefined value in case of any trouble.
278 my ($input_file) = @_;
281 # silently ignore input from object or stdin
282 if ( ref($input_file) || $input_file eq '-' ) {
287 open( $fh, '<', $input_file ) || return $ending;
291 read( $fh, $buf, 1024 );
292 close $fh || return $ending;
293 if ( $buf && $buf =~ /([\012\015]+)/ ) {
297 if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
300 elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
303 elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
313 } ## end sub find_input_line_ending
315 { ## begin closure for sub catfile
317 my $missing_file_spec;
320 $missing_file_spec = !eval { require File::Spec; 1 };
325 # concatenate a path and file basename
326 # returns undef in case of error
330 # use File::Spec if we can
331 unless ($missing_file_spec) {
332 return File::Spec->catfile(@parts);
335 # Perl 5.004 systems may not have File::Spec so we'll make
336 # a simple try. We assume File::Basename is available.
337 # return if not successful.
338 my $name = pop @parts;
339 my $path = join '/', @parts;
340 my $test_file = $path . $name;
341 my ( $test_name, $test_path ) = fileparse($test_file);
342 return $test_file if ( $test_name eq $name );
343 return if ( $OSNAME eq 'VMS' );
345 # this should work at least for Windows and Unix:
346 $test_file = $path . '/' . $name;
347 ( $test_name, $test_path ) = fileparse($test_file);
348 return $test_file if ( $test_name eq $name );
351 } ## end closure for sub catfile
353 # Here is a map of the flow of data from the input source to the output
356 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
357 # input groups output
358 # lines tokens lines of lines lines
361 # The names correspond to the package names responsible for the unit processes.
363 # The overall process is controlled by the "main" package.
365 # LineSource is the stream of input lines
367 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
368 # if necessary. A token is any section of the input line which should be
369 # manipulated as a single entity during formatting. For example, a single
370 # ',' character is a token, and so is an entire side comment. It handles
371 # the complexities of Perl syntax, such as distinguishing between '<<' as
372 # a shift operator and as a here-document, or distinguishing between '/'
373 # as a divide symbol and as a pattern delimiter.
375 # Formatter inserts and deletes whitespace between tokens, and breaks
376 # sequences of tokens at appropriate points as output lines. It bases its
377 # decisions on the default rules as modified by any command-line options.
379 # VerticalAligner collects groups of lines together and tries to line up
380 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
382 # FileWriter simply writes lines to the output stream.
384 # The Logger package, not shown, records significant events and warning
385 # messages. It writes a .LOG file, which may be saved with a
386 # '-log' or a '-g' flag.
388 { #<<< (this side comment avoids excessive indentation in a closure)
392 my $loaded_unicode_gcstring;
395 # Bump Warn_count only: it is essential to bump the count on all warnings, even
396 # if no message goes out, so that the correct exit status is set.
397 sub Warn_count_bump { $Warn_count++; return }
399 # Output Warn message only
400 sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return }
402 # Output Warn message and bump Warn count
403 sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
410 # true if $string is in Perl's internal character mode
411 # (also called the 'upgraded form', or UTF8=1)
412 # false if $string is in Perl's internal byte mode
414 # This function isolates the call to Perl's internal function
415 # utf8::is_utf8() which is true for strings represented in an 'upgraded
416 # form'. It is available after Perl version 5.8.
417 # See https://perldoc.perl.org/Encode.
418 # See also comments in Carp.pm and other modules using this function
420 return 1 if ( utf8::is_utf8($string) );
422 } ## end sub is_char_mode
427 # Evaluate the MD5 sum for a string
428 # Patch for [rt.cpan.org #88020]
429 # Use utf8::encode since md5_hex() only operates on bytes.
430 # my $digest = md5_hex( utf8::encode($sink_buffer) );
432 # Note added 20180114: the above patch did not work correctly. I'm not
433 # sure why. But switching to the method recommended in the Perl 5
434 # documentation for Encode worked. According to this we can either use
435 # $octets = encode_utf8($string) or equivalently
436 # $octets = encode("utf8",$string)
437 # and then calculate the checksum. So:
438 my $octets = Encode::encode( "utf8", $buf );
439 my $digest = md5_hex($octets);
445 # Array index names for $self.
446 # Do not combine with other BEGIN blocks (c101).
449 _actual_output_extension_ => $i++,
450 _debugfile_stream_ => $i++,
451 _decoded_input_as_ => $i++,
452 _destination_stream_ => $i++,
453 _diagnostics_object_ => $i++,
454 _display_name_ => $i++,
455 _file_extension_separator_ => $i++,
457 _is_encoded_data_ => $i++,
458 _length_function_ => $i++,
459 _line_separator_default_ => $i++,
460 _line_separator_ => $i++,
461 _logger_object_ => $i++,
462 _output_file_ => $i++,
463 _postfilter_ => $i++,
468 _teefile_stream_ => $i++,
469 _user_formatter_ => $i++,
470 _input_copied_verbatim_ => $i++,
471 _input_output_difference_ => $i++,
481 destination => undef,
490 dump_options => undef,
491 dump_options_type => undef,
492 dump_getopt_flags => undef,
493 dump_options_category => undef,
494 dump_options_range => undef,
495 dump_abbreviations => undef,
500 # Status information which can be returned for diagnostic purposes.
501 # NOTE: This is intended only for testing and subject to change.
503 # List of "key => value" hash entries:
505 # Some relevant user input parameters for convenience:
506 # opt_format => value of --format: 'tidy', 'html', or 'user'
507 # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess'
508 # opt_encode_output => value of -eos flag: 'eos' or 'neos'
509 # opt_max_iterations => value of --iterations=n
511 # file_count => number of files processed in this call
513 # If multiple files are processed, then the following values will be for
514 # the last file only:
516 # input_name => name of the input stream
517 # output_name => name of the output stream
519 # The following two variables refer to Perl's two internal string modes,
520 # and have the values 0 for 'byte' mode and 1 for 'char' mode:
521 # char_mode_source => true if source is in 'char' mode. Will be false
522 # unless we received a source string ref with utf8::is_utf8() set.
523 # char_mode_used => true if text processed by perltidy in 'char' mode.
524 # Normally true for text identified as utf8, otherwise false.
526 # This tells if Unicode::GCString was used
527 # gcs_used => true if -gcs and Unicode::GCString found & used
529 # These variables tell what utf8 decoding/encoding was done:
530 # input_decoded_as => non-blank if perltidy decoded the source text
531 # output_encoded_as => non-blank if perltidy encoded before return
533 # These variables are related to iterations and convergence testing:
534 # iteration_count => number of iterations done
535 # ( can be from 1 to opt_max_iterations )
536 # converged => true if stopped on convergence
537 # ( can only happen if opt_max_iterations > 1 )
538 # blinking => true if stopped on blinking states
539 # ( i.e., unstable formatting, should not happen )
544 opt_format => EMPTY_STRING,
545 opt_encoding => EMPTY_STRING,
546 opt_encode_output => EMPTY_STRING,
547 opt_max_iterations => EMPTY_STRING,
549 input_name => EMPTY_STRING,
550 output_name => EMPTY_STRING,
551 char_mode_source => 0,
553 input_decoded_as => EMPTY_STRING,
554 output_encoded_as => EMPTY_STRING,
556 iteration_count => 0,
561 # Fix for issue git #57
564 # don't overwrite callers ARGV
566 local *STDERR = *STDERR;
568 if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
569 local $LIST_SEPARATOR = ')(';
570 my @good_keys = sort keys %defaults;
571 @bad_keys = sort @bad_keys;
573 ------------------------------------------------------------------------
574 Unknown perltidy parameter : (@bad_keys)
575 perltidy only understands : (@good_keys)
576 ------------------------------------------------------------------------
581 my $get_hash_ref = sub {
583 my $hash_ref = $input_hash{$key};
584 if ( defined($hash_ref) ) {
585 unless ( ref($hash_ref) eq 'HASH' ) {
586 my $what = ref($hash_ref);
588 $what ? "but is ref to $what" : "but is not a reference";
590 ------------------------------------------------------------------------
591 error in call to perltidy:
592 -$key must be reference to HASH $but_is
593 ------------------------------------------------------------------------
600 %input_hash = ( %defaults, %input_hash );
601 my $argv = $input_hash{'argv'};
602 my $destination_stream = $input_hash{'destination'};
603 my $errorfile_stream = $input_hash{'errorfile'};
604 my $logfile_stream = $input_hash{'logfile'};
605 my $teefile_stream = $input_hash{'teefile'};
606 my $debugfile_stream = $input_hash{'debugfile'};
607 my $perltidyrc_stream = $input_hash{'perltidyrc'};
608 my $source_stream = $input_hash{'source'};
609 my $stderr_stream = $input_hash{'stderr'};
610 my $user_formatter = $input_hash{'formatter'};
611 my $prefilter = $input_hash{'prefilter'};
612 my $postfilter = $input_hash{'postfilter'};
614 if ($stderr_stream) {
615 ( $fh_stderr, my $stderr_file ) =
616 Perl::Tidy::streamhandle( $stderr_stream, 'w' );
619 ------------------------------------------------------------------------
620 Unable to redirect STDERR to $stderr_stream
621 Please check value of -stderr in call to perltidy
622 ------------------------------------------------------------------------
627 $fh_stderr = *STDERR;
631 bless $self, __PACKAGE__;
635 if ($flag) { goto ERROR_EXIT }
636 else { goto NORMAL_EXIT }
637 croak "unexpectd return to Exit";
644 croak "unexpected return to Die";
650 # This routine is called for errors that really should not occur
651 # except if there has been a bug introduced by a recent program change.
652 # Please add comments at calls to Fault to explain why the call
653 # should not occur, and where to look to fix it.
654 my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
655 my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
656 my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
657 my $pkg = __PACKAGE__;
659 my $input_stream_name = $rstatus->{'input_name'};
660 $input_stream_name = '(unknown)' unless ($input_stream_name);
662 ==============================================================================
663 While operating on input stream with name: '$input_stream_name'
664 A fault was detected at line $line0 of sub '$subroutine1'
666 which was called from line $line1 of sub '$subroutine2'
668 This is probably an error introduced by a recent programming change.
669 $pkg reports VERSION='$VERSION'.
670 ==============================================================================
673 # This return is to keep Perl-Critic from complaining.
677 # extract various dump parameters
678 my $dump_options_type = $input_hash{'dump_options_type'};
679 my $dump_options = $get_hash_ref->('dump_options');
680 my $dump_getopt_flags = $get_hash_ref->('dump_getopt_flags');
681 my $dump_options_category = $get_hash_ref->('dump_options_category');
682 my $dump_abbreviations = $get_hash_ref->('dump_abbreviations');
683 my $dump_options_range = $get_hash_ref->('dump_options_range');
685 # validate dump_options_type
686 if ( defined($dump_options) ) {
687 unless ( defined($dump_options_type) ) {
688 $dump_options_type = 'perltidyrc';
690 if ( $dump_options_type ne 'perltidyrc'
691 && $dump_options_type ne 'full' )
694 ------------------------------------------------------------------------
695 Please check value of -dump_options_type in call to perltidy;
696 saw: '$dump_options_type'
697 expecting: 'perltidyrc' or 'full'
698 ------------------------------------------------------------------------
704 $dump_options_type = EMPTY_STRING;
707 if ($user_formatter) {
709 # if the user defines a formatter, there is no output stream,
710 # but we need a null stream to keep coding simple
711 $destination_stream = Perl::Tidy::DevNull->new();
714 # see if ARGV is overridden
715 if ( defined($argv) ) {
717 my $rargv = ref $argv;
718 if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
722 if ( $rargv eq 'ARRAY' ) {
727 ------------------------------------------------------------------------
728 Please check value of -argv in call to perltidy;
729 it must be a string or ref to ARRAY but is: $rargv
730 ------------------------------------------------------------------------
737 my ( $rargv_str, $msg ) = parse_args($argv);
740 Error parsing this string passed to to perltidy with 'argv':
744 @ARGV = @{$rargv_str};
748 # These string refs will hold any warnings and error messages to be written
749 # to the logfile object when it eventually gets created.
750 my $rpending_complaint;
751 ${$rpending_complaint} = EMPTY_STRING;
753 my $rpending_logfile_message;
754 ${$rpending_logfile_message} = EMPTY_STRING;
756 my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
758 # VMS file names are restricted to a 40.40 format, so we append _tdy
759 # instead of .tdy, etc. (but see also sub check_vms_filename)
762 if ( $OSNAME eq 'VMS' ) {
768 $dot_pattern = '\.'; # must escape for use in regex
770 $self->[_file_extension_separator_] = $dot;
772 #-------------------------
773 # get command line options
774 #-------------------------
775 my ( $rOpts, $config_file, $rraw_options, $roption_string,
776 $rexpansion, $roption_category, $roption_range )
777 = process_command_line(
778 $perltidyrc_stream, $is_Windows, $Windows_type,
779 $rpending_complaint, $dump_options_type,
782 # Only filenames should remain in @ARGV
783 my @Arg_files = @ARGV;
785 $self->[_rOpts_] = $rOpts;
788 grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options};
789 $self->[_saw_pbp_] = $saw_pbp;
791 #------------------------------------
792 # Handle requests to dump information
793 #------------------------------------
795 # return or exit immediately after all dumps
798 # Getopt parameters and their flags
799 if ( defined($dump_getopt_flags) ) {
801 foreach my $op ( @{$roption_string} ) {
803 my $flag = EMPTY_STRING;
810 if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
814 $dump_getopt_flags->{$opt} = $flag;
818 if ( defined($dump_options_category) ) {
820 %{$dump_options_category} = %{$roption_category};
823 if ( defined($dump_options_range) ) {
825 %{$dump_options_range} = %{$roption_range};
828 if ( defined($dump_abbreviations) ) {
830 %{$dump_abbreviations} = %{$rexpansion};
833 if ( defined($dump_options) ) {
835 %{$dump_options} = %{$rOpts};
838 Exit(0) if ($quit_now);
840 # make printable string of options for this run as possible diagnostic
841 my $readable_options = readable_options( $rOpts, $roption_string );
843 # dump from command line
844 if ( $rOpts->{'dump-options'} ) {
845 print STDOUT $readable_options;
849 # --dump-block-summary requires one filename in the arg list.
850 # This is a safety precaution in case a user accidentally adds -dbs to the
851 # command line parameters and is expecting formatted output to stdout.
852 # Another precaution, added elsewhere, is to ignore -dbs in a .perltidyrc
853 my $numf = @Arg_files;
854 if ( $rOpts->{'dump-block-summary'} && $numf != 1 ) {
856 --dump-block-summary expects 1 filename in the arg list but saw $numf filenames
860 #----------------------------------------
861 # check parameters and their interactions
862 #----------------------------------------
863 $self->check_options( $is_Windows, $Windows_type, $rpending_complaint );
865 if ($user_formatter) {
866 $rOpts->{'format'} = 'user';
869 # there must be one entry here for every possible format
870 my %default_file_extension = (
873 user => EMPTY_STRING,
876 $rstatus->{'opt_format'} = $rOpts->{'format'};
877 $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'};
878 $rstatus->{'opt_encode_output'} =
879 $rOpts->{'encode-output-strings'} ? 'eos' : 'neos';
881 # be sure we have a valid output format
882 unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
883 my $formats = join SPACE,
884 sort map { "'" . $_ . "'" } keys %default_file_extension;
885 my $fmt = $rOpts->{'format'};
886 Die("-format='$fmt' but must be one of: $formats\n");
889 my $output_extension =
890 $self->make_file_extension( $rOpts->{'output-file-extension'},
891 $default_file_extension{ $rOpts->{'format'} } );
893 # get parameters associated with the -b option
894 my ( $in_place_modify, $backup_extension, $delete_backup ) =
895 $self->check_in_place_modify( $source_stream, $destination_stream );
897 Perl::Tidy::Formatter::check_options($rOpts);
898 Perl::Tidy::Tokenizer::check_options($rOpts);
899 Perl::Tidy::VerticalAligner::check_options($rOpts);
900 if ( $rOpts->{'format'} eq 'html' ) {
901 Perl::Tidy::HtmlWriter->check_options($rOpts);
904 # make the pattern of file extensions that we shouldn't touch
905 my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
906 if ($output_extension) {
907 my $ext = quotemeta($output_extension);
908 $forbidden_file_extensions .= "|$ext";
910 if ( $in_place_modify && $backup_extension ) {
911 my $ext = quotemeta($backup_extension);
912 $forbidden_file_extensions .= "|$ext";
914 $forbidden_file_extensions .= ')$';
916 # Create a diagnostics object if requested;
917 # This is only useful for code development
918 my $diagnostics_object = undef;
919 if ( $rOpts->{'DIAGNOSTICS'} ) {
920 $diagnostics_object = Perl::Tidy::Diagnostics->new();
923 # no filenames should be given if input is from an array
924 if ($source_stream) {
925 if ( @Arg_files > 0 ) {
927 "You may not specify any filenames when a source array is given\n"
931 # we'll stuff the source array into Arg_files
932 unshift( @Arg_files, $source_stream );
934 # No special treatment for source stream which is a filename.
935 # This will enable checks for binary files and other bad stuff.
936 $source_stream = undef unless ref($source_stream);
939 # use stdin by default if no source array and no args
941 unshift( @Arg_files, '-' ) unless @Arg_files;
944 # Flag for loading module Unicode::GCString for evaluating text width:
945 # undef = ok to use but not yet loaded
946 # 0 = do not use; failed to load or not wanted
947 # 1 = successfully loaded and ok to use
948 # The module is not actually loaded unless/until it is needed
949 if ( !$rOpts->{'use-unicode-gcstring'} ) {
950 $loaded_unicode_gcstring = 0;
953 # Remove duplicate filenames. Otherwise, for example if the user entered
954 # perltidy -b myfile.pl myfile.pl
955 # the backup version of the original would be lost.
956 if ( @Arg_files > 1 ) {
958 @Arg_files = grep { !$seen{$_}++ } @Arg_files;
961 # If requested, process in order of increasing file size
962 # This can significantly reduce perl's virtual memory usage during testing.
963 if ( @Arg_files > 1 && $rOpts->{'file-size-order'} ) {
966 sort { $a->[1] <=> $b->[1] }
967 map { [ $_, -e $_ ? -s $_ : 0 ] } @Arg_files;
970 my $logfile_header = make_logfile_header( $rOpts, $config_file,
971 $rraw_options, $Windows_type, $readable_options, );
973 # Store some values needed by lower level routines
974 $self->[_diagnostics_object_] = $diagnostics_object;
975 $self->[_postfilter_] = $postfilter;
976 $self->[_prefilter_] = $prefilter;
977 $self->[_user_formatter_] = $user_formatter;
979 #--------------------------
980 # loop to process all files
981 #--------------------------
982 $self->process_all_files(
989 $forbidden_file_extensions,
997 $rpending_logfile_message,
1005 # Fix for RT #130297: return a true value if anything was written to the
1006 # standard error output, even non-fatal warning messages, otherwise return
1009 # These exit codes are returned:
1010 # 0 = perltidy ran to completion with no errors
1011 # 1 = perltidy could not run to completion due to errors
1012 # 2 = perltidy ran to completion with error messages
1014 # Note that if perltidy is run with multiple files, any single file with
1015 # errors or warnings will write a line like
1016 # '## Please see file testing.t.ERR'
1017 # to standard output for each file with errors, so the flag will be true,
1018 # even if only some of the multiple files may have had errors.
1021 my $ret = $Warn_count ? 2 : 0;
1022 return wantarray ? ( $ret, $rstatus ) : $ret;
1025 return wantarray ? ( 1, $rstatus ) : 1;
1027 } ## end sub perltidy
1029 sub make_file_extension {
1031 # Make a file extension, adding any leading '.' if necessary.
1032 # (the '.' may actually be an '_' under VMS).
1033 my ( $self, $extension, $default ) = @_;
1035 # '$extension' is the first choice (usually a user entry)
1036 # '$default' is a backup extension
1038 $extension = EMPTY_STRING unless defined($extension);
1039 $extension =~ s/^\s+//;
1040 $extension =~ s/\s+$//;
1042 # Use default extension if nothing remains of the first choice
1044 if ( length($extension) == 0 ) {
1045 $extension = $default;
1046 $extension = EMPTY_STRING unless defined($extension);
1047 $extension =~ s/^\s+//;
1048 $extension =~ s/\s+$//;
1051 # Only extensions with these leading characters get a '.'
1052 # This rule gives the user some freedom.
1053 if ( $extension =~ /^[a-zA-Z0-9]/ ) {
1054 my $dot = $self->[_file_extension_separator_];
1055 $extension = $dot . $extension;
1058 } ## end sub make_file_extension
1060 sub check_in_place_modify {
1062 my ( $self, $source_stream, $destination_stream ) = @_;
1064 # get parameters associated with the -b option
1065 my $rOpts = $self->[_rOpts_];
1067 # check for -b option;
1068 # silently ignore unless beautify mode
1069 my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
1070 && $rOpts->{'format'} eq 'tidy';
1072 my ( $backup_extension, $delete_backup );
1074 # Turn off -b with warnings in case of conflicts with other options.
1075 # NOTE: Do this silently, without warnings, if there is a source or
1076 # destination stream, or standard output is used. This is because the -b
1077 # flag may have been in a .perltidyrc file and warnings break
1078 # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014.
1079 if ($in_place_modify) {
1080 if ( $rOpts->{'standard-output'}
1081 || $destination_stream
1082 || ref $source_stream
1083 || $rOpts->{'outfile'}
1084 || defined( $rOpts->{'output-path'} ) )
1086 $in_place_modify = 0;
1090 if ($in_place_modify) {
1092 # If the backup extension contains a / character then the backup should
1093 # be deleted when the -b option is used. On older versions of
1094 # perltidy this will generate an error message due to an illegal
1097 # A backup file will still be generated but will be deleted
1098 # at the end. If -bext='/' then this extension will be
1099 # the default 'bak'. Otherwise it will be whatever characters
1100 # remains after all '/' characters are removed. For example:
1101 # -bext extension slashes
1103 # '/delete' delete 1
1104 # 'delete/' delete 1
1105 # '/dev/null' devnull 2 (Currently not allowed)
1106 my $bext = $rOpts->{'backup-file-extension'};
1107 $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
1109 # At present only one forward slash is allowed. In the future multiple
1110 # slashes may be allowed to allow for other options
1111 if ( $delete_backup > 1 ) {
1112 Die("-bext=$bext contains more than one '/'\n");
1116 $self->make_file_extension( $rOpts->{'backup-file-extension'},
1120 my $backup_method = $rOpts->{'backup-method'};
1121 if ( defined($backup_method)
1122 && $backup_method ne 'copy'
1123 && $backup_method ne 'move' )
1126 "Unexpected --backup-method='$backup_method'; must be one of: 'move', 'copy'\n"
1130 return ( $in_place_modify, $backup_extension, $delete_backup );
1131 } ## end sub check_in_place_modify
1133 sub backup_method_copy {
1135 my ( $self, $input_file, $output_file, $backup_extension, $delete_backup )
1138 # Handle the -b (--backup-and-modify-in-place) option with -bm='copy':
1139 # - First copy $input file to $backup_name.
1140 # - Then open input file and rewrite with contents of $output_file
1141 # - Then delete the backup if requested
1144 # - Die immediately on any error.
1145 # - $output_file is actually an ARRAY ref
1147 my $backup_file = $input_file . $backup_extension;
1149 unless ( -f $input_file ) {
1151 # no real file to backup ..
1152 # This shouldn't happen because of numerous preliminary checks
1154 "problem with -b backing up input file '$input_file': not a file\n"
1158 if ( -f $backup_file ) {
1159 unlink($backup_file)
1161 "unable to remove previous '$backup_file' for -b option; check permissions: $ERRNO\n"
1165 # Copy input file to backup
1166 File::Copy::copy( $input_file, $backup_file )
1167 or Die("File::Copy failed trying to backup source: $ERRNO");
1169 # set permissions of the backup file to match the input file
1170 my @input_file_stat = stat($input_file);
1171 my $in_place_modify = 1;
1172 $self->set_output_file_permissions( $backup_file, \@input_file_stat,
1175 # set the modification time of the copy to the original value (rt#145999)
1176 my ( $read_time, $write_time ) = @input_file_stat[ 8, 9 ];
1177 if ( defined($write_time) ) {
1178 utime( $read_time, $write_time, $backup_file )
1179 || Warn("error setting times for backup file '$backup_file'\n");
1182 # Open the original input file for writing ... opening with ">" will
1183 # truncate the existing data.
1184 open( my $fout, ">", $input_file )
1186 "problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
1189 if ( $self->[_is_encoded_data_] ) {
1190 binmode $fout, ":raw:encoding(UTF-8)";
1193 # Now copy the formatted output to it..
1195 # if formatted output is in an ARRAY ref (normally this is true)...
1196 if ( ref($output_file) eq 'ARRAY' ) {
1197 foreach my $line ( @{$output_file} ) {
1200 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1204 # or in a SCALAR ref (less efficient, and only used for testing)
1205 elsif ( ref($output_file) eq 'SCALAR' ) {
1206 foreach my $line ( split /^/, ${$output_file} ) {
1209 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1213 # Error if anything else ...
1214 # This can only happen if the output was changed from \@tmp_buff
1216 my $ref = ref($output_file);
1218 Programming error: unable to print to '$input_file' with -b option:
1219 unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
1224 or Die("cannot close '$input_file' with -b option: $OS_ERROR\n");
1226 # Set permissions of the output file to match the input file. This is
1227 # necessary even if the inode remains unchanged because suid/sgid bits may
1229 $self->set_output_file_permissions( $input_file, \@input_file_stat,
1232 # Keep original modification time if no change (rt#145999)
1233 if ( !$self->[_input_output_difference_] && defined($write_time) ) {
1234 utime( $read_time, $write_time, $input_file )
1235 || Warn("error setting times for '$input_file'\n");
1238 #---------------------------------------------------------
1239 # remove the original file for in-place modify as follows:
1240 # $delete_backup=0 never
1241 # $delete_backup=1 only if no errors
1242 # $delete_backup>1 always : NOT ALLOWED, too risky
1243 #---------------------------------------------------------
1244 if ( $delete_backup && -f $backup_file ) {
1246 # Currently, $delete_backup may only be 1. But if a future update
1247 # allows a value > 1, then reduce it to 1 if there were warnings.
1248 if ( $delete_backup > 1
1249 && $self->[_logger_object_]->get_warning_count() )
1254 # As an added safety precaution, do not delete the source file
1255 # if its size has dropped from positive to zero, since this
1256 # could indicate a disaster of some kind, including a hardware
1257 # failure. Actually, this could happen if you had a file of
1258 # all comments (or pod) and deleted everything with -dac (-dap)
1260 if ( !-s $input_file && -s $backup_file && $delete_backup == 1 ) {
1262 "output file '$input_file' missing or zero length; original '$backup_file' not deleted\n"
1266 unlink($backup_file)
1268 "unable to remove backup file '$backup_file' for -b option; check permissions: $ERRNO\n"
1273 # Verify that inode is unchanged during development
1275 my @output_file_stat = stat($input_file);
1276 my $inode_input = $input_file_stat[1];
1277 my $inode_output = $output_file_stat[1];
1278 if ( $inode_input != $inode_output ) {
1280 inode changed with -bm=copy for file '$input_file': inode_input=$inode_input inode_output=$inode_output
1286 } ## end sub backup_method_copy
1288 sub backup_method_move {
1290 my ( $self, $input_file, $output_file, $backup_extension, $delete_backup )
1293 # Handle the -b (--backup-and-modify-in-place) option with -bm='move':
1294 # - First move $input file to $backup_name.
1295 # - Then copy $output_file to $input_file.
1296 # - Then delete the backup if requested
1299 # - Die immediately on any error.
1300 # - $output_file is actually an ARRAY ref
1301 # - $input_file permissions will be set by sub set_output_file_permissions
1303 my $backup_name = $input_file . $backup_extension;
1305 unless ( -f $input_file ) {
1307 # oh, oh, no real file to backup ..
1308 # shouldn't happen because of numerous preliminary checks
1310 "problem with -b backing up input file '$input_file': not a file\n"
1313 if ( -f $backup_name ) {
1314 unlink($backup_name)
1316 "unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
1320 my @input_file_stat = stat($input_file);
1322 # backup the input file
1323 # we use copy for symlinks, move for regular files
1324 if ( -l $input_file ) {
1325 File::Copy::copy( $input_file, $backup_name )
1326 or Die("File::Copy failed trying to backup source: $ERRNO");
1329 rename( $input_file, $backup_name )
1331 "problem renaming $input_file to $backup_name for -b option: $ERRNO\n"
1335 # Open a file with the original input file name for writing ...
1336 my $is_encoded_data = $self->[_is_encoded_data_];
1337 my ( $fout, $iname ) =
1338 Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data );
1341 "problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n"
1345 # Now copy the formatted output to it..
1347 # if formatted output is in an ARRAY ref ...
1348 if ( ref($output_file) eq 'ARRAY' ) {
1349 foreach my $line ( @{$output_file} ) {
1352 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1356 # or in a SCALAR ref (less efficient, for testing only)
1357 elsif ( ref($output_file) eq 'SCALAR' ) {
1358 foreach my $line ( split /^/, ${$output_file} ) {
1361 Die("cannot print to '$input_file' with -b option: $OS_ERROR\n");
1365 # Error if anything else ...
1366 # This can only happen if the output was changed from \@tmp_buff
1368 my $ref = ref($output_file);
1370 Programming error: unable to print to '$input_file' with -b option:
1371 unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
1376 or Die("cannot close '$input_file' with -b option: $OS_ERROR\n");
1378 # set permissions of the output file to match the input file
1379 my $in_place_modify = 1;
1380 $self->set_output_file_permissions( $input_file, \@input_file_stat,
1383 # Keep original modification time if no change (rt#145999)
1384 my ( $read_time, $write_time ) = @input_file_stat[ 8, 9 ];
1385 if ( !$self->[_input_output_difference_] && defined($write_time) ) {
1386 utime( $read_time, $write_time, $input_file )
1387 || Warn("error setting times for '$input_file'\n");
1390 #---------------------------------------------------------
1391 # remove the original file for in-place modify as follows:
1392 # $delete_backup=0 never
1393 # $delete_backup=1 only if no errors
1394 # $delete_backup>1 always : NOT ALLOWED, too risky
1395 #---------------------------------------------------------
1396 if ( $delete_backup && -f $backup_name ) {
1398 # Currently, $delete_backup may only be 1. But if a future update
1399 # allows a value > 1, then reduce it to 1 if there were warnings.
1400 if ( $delete_backup > 1
1401 && $self->[_logger_object_]->get_warning_count() )
1406 # As an added safety precaution, do not delete the source file
1407 # if its size has dropped from positive to zero, since this
1408 # could indicate a disaster of some kind, including a hardware
1409 # failure. Actually, this could happen if you had a file of
1410 # all comments (or pod) and deleted everything with -dac (-dap)
1412 if ( !-s $input_file && -s $backup_name && $delete_backup == 1 ) {
1414 "output file '$input_file' missing or zero length; original '$backup_name' not deleted\n"
1418 unlink($backup_name)
1420 "unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n"
1427 } ## end sub backup_method_move
1429 sub set_output_file_permissions {
1431 my ( $self, $output_file, $rinput_file_stat, $in_place_modify ) = @_;
1434 # $output_file = the file whose permissions we will set
1435 # $rinput_file_stat = the result of stat($input_file)
1436 # $in_place_modify = true if --backup-and-modify-in-place is set
1438 my ( $mode_i, $uid_i, $gid_i ) = @{$rinput_file_stat}[ 2, 4, 5 ];
1439 my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
1440 my $input_file_permissions = $mode_i & oct(7777);
1441 my $output_file_permissions = $input_file_permissions;
1443 #rt128477: avoid inconsistent owner/group and suid/sgid
1444 if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
1446 # try to change owner and group to match input file if
1447 # in -b mode. Note: chown returns number of files
1448 # successfully changed.
1449 if ( $in_place_modify
1450 && chown( $uid_i, $gid_i, $output_file ) )
1452 # owner/group successfully changed
1456 # owner or group differ: do not copy suid and sgid
1457 $output_file_permissions = $mode_i & oct(777);
1458 if ( $input_file_permissions != $output_file_permissions ) {
1460 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
1466 # Mark the output file for rw unless we are in -b mode.
1467 # Explanation: perltidy does not unlink existing output
1468 # files before writing to them, for safety. If a
1469 # designated output file exists and is not writable,
1470 # perltidy will halt. This can prevent a data loss if a
1471 # user accidentally enters "perltidy infile -o
1472 # important_ro_file", or "perltidy infile -st
1473 # >important_ro_file". But it also means that perltidy can
1474 # get locked out of rerunning unless it marks its own
1475 # output files writable. The alternative, of always
1476 # unlinking the designated output file, is less safe and
1477 # not always possible, except in -b mode, where there is an
1478 # assumption that a previous backup can be unlinked even if
1480 if ( !$in_place_modify ) {
1481 $output_file_permissions |= oct(600);
1484 if ( !chmod( $output_file_permissions, $output_file ) ) {
1486 # couldn't change file permissions
1487 my $operm = sprintf "%04o", $output_file_permissions;
1489 "Unable to set permissions for output file '$output_file' to $operm\n"
1493 } ## end sub set_output_file_permissions
1495 sub get_decoded_string_buffer {
1496 my ( $self, $input_file, $display_name, $rpending_logfile_message ) = @_;
1498 # Decode the input buffer if necessary or requested
1501 # $input_file = the input file or stream
1502 # $display_name = its name to use in error messages
1505 # $buf = string buffer with input, decoded from utf8 if necessary
1506 # $is_encoded_data = true if $buf is decoded from utf8
1507 # $decoded_input_as = true if perltidy decoded input buf
1508 # $encoding_log_message = messages for log file,
1509 # $length_function = function to use for measuring string width
1511 # Return nothing on any error; this is a signal to skip this file
1513 my $rOpts = $self->[_rOpts_];
1515 my $source_object = Perl::Tidy::LineSource->new(
1516 input_file => $input_file,
1520 # return nothing if error
1521 return unless ($source_object);
1523 my $buf = EMPTY_STRING;
1524 while ( my $line = $source_object->get_line() ) {
1528 my $encoding_in = EMPTY_STRING;
1529 my $rOpts_character_encoding = $rOpts->{'character-encoding'};
1530 my $encoding_log_message;
1531 my $decoded_input_as = EMPTY_STRING;
1532 $rstatus->{'char_mode_source'} = 0;
1534 # Case 1: If Perl is already in a character-oriented mode for this
1535 # string rather than a byte-oriented mode. Normally, this happens if
1536 # the caller has decoded a utf8 string before calling perltidy. But it
1537 # could also happen if the user has done some unusual manipulations of
1538 # the source. In any case, we will not attempt to decode it because
1539 # that could result in an output string in a different mode.
1540 if ( is_char_mode($buf) ) {
1541 $encoding_in = "utf8";
1542 $rstatus->{'char_mode_source'} = 1;
1545 # Case 2. No input stream encoding requested. This is appropriate
1546 # for single-byte encodings like ascii, latin-1, etc
1547 elsif ( !$rOpts_character_encoding
1548 || $rOpts_character_encoding eq 'none' )
1554 # Case 3. guess input stream encoding if requested
1555 elsif ( lc($rOpts_character_encoding) eq 'guess' ) {
1557 # The guessing strategy is simple: use Encode::Guess to guess
1558 # an encoding. If and only if the guess is utf8, try decoding and
1559 # use it if successful. Otherwise, we proceed assuming the
1560 # characters are encoded as single bytes (same as if 'none' had
1561 # been specified as the encoding).
1563 # In testing I have found that including additional guess 'suspect'
1564 # encodings sometimes works but can sometimes lead to disaster by
1565 # using an incorrect decoding.
1568 my $decoder = guess_encoding( $buf_in, 'utf8' );
1569 if ( ref($decoder) ) {
1570 $encoding_in = $decoder->name;
1571 if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) {
1572 $encoding_in = EMPTY_STRING;
1574 $encoding_log_message .= <<EOM;
1575 Guessed encoding '$encoding_in' is not utf8; no encoding will be used
1580 if ( !eval { $buf = $decoder->decode($buf_in); 1 } ) {
1582 $encoding_log_message .= <<EOM;
1583 Guessed encoding '$encoding_in' but decoding was unsuccessful; no encoding is used
1586 # Note that a guess failed, but keep going
1587 # This warning can eventually be removed
1589 "file: $display_name: bad guess to decode source as $encoding_in\n"
1591 $encoding_in = EMPTY_STRING;
1595 $encoding_log_message .= <<EOM;
1596 Guessed encoding '$encoding_in' successfully decoded
1598 $decoded_input_as = $encoding_in;
1603 $encoding_log_message .= <<EOM;
1604 Does not look like utf8 encoded text so processing as raw bytes
1609 # Case 4. Decode with a specific encoding
1611 $encoding_in = $rOpts_character_encoding;
1614 $buf = Encode::decode( $encoding_in, $buf,
1615 Encode::FB_CROAK | Encode::LEAVE_SRC );
1621 # Quit if we cannot decode by the requested encoding;
1622 # Something is not right.
1624 "skipping file: $display_name: Unable to decode source as $encoding_in\n"
1627 # return nothing on error
1631 $encoding_log_message .= <<EOM;
1632 Specified encoding '$encoding_in' successfully decoded
1634 $decoded_input_as = $encoding_in;
1638 # Set the encoding to be used for all further i/o: If we have
1639 # decoded the data with any format, then we must continue to
1640 # read and write it as encoded data, and we will normalize these
1641 # operations with utf8. If we have not decoded the data, then
1642 # we must not treat it as encoded data.
1643 my $is_encoded_data = $encoding_in ? 'utf8' : EMPTY_STRING;
1644 $self->[_is_encoded_data_] = $is_encoded_data;
1646 # Delete any Byte Order Mark (BOM), which can cause trouble
1647 if ($is_encoded_data) {
1648 $buf =~ s/^\x{FEFF}//;
1651 $rstatus->{'input_name'} = $display_name;
1652 $rstatus->{'opt_encoding'} = $rOpts_character_encoding;
1653 $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0;
1654 $rstatus->{'input_decoded_as'} = $decoded_input_as;
1656 # Define the function to determine the display width of character
1658 my $length_function = sub { return length( $_[0] ) };
1659 if ($is_encoded_data) {
1661 # Try to load Unicode::GCString for defining text display width, if
1662 # requested, when the first encoded file is encountered
1663 if ( !defined($loaded_unicode_gcstring) ) {
1664 if ( eval { require Unicode::GCString; 1 } ) {
1665 $loaded_unicode_gcstring = 1;
1668 $loaded_unicode_gcstring = 0;
1669 if ( $rOpts->{'use-unicode-gcstring'} ) {
1671 ----------------------
1672 Unable to load Unicode::GCString: $EVAL_ERROR
1673 Processing continues but some vertical alignment may be poor
1674 To prevent this warning message, you can either:
1675 - install module Unicode::GCString, or
1676 - remove '--use-unicode-gcstring' or '-gcs' from your perltidyrc or command line
1677 ----------------------
1682 if ($loaded_unicode_gcstring) {
1683 $length_function = sub {
1684 return Unicode::GCString->new( $_[0] )->columns;
1686 $encoding_log_message .= <<EOM;
1687 Using 'Unicode::GCString' to measure horizontal character widths
1689 $rstatus->{'gcs_used'} = 1;
1696 $encoding_log_message,
1700 } ## end sub get_decoded_string_buffer
1702 sub process_all_files {
1711 $forbidden_file_extensions,
1717 $rpending_complaint,
1718 $rpending_logfile_message,
1722 # This routine is the main loop to process all files.
1723 # Total formatting is done with these layers of subroutines:
1724 # perltidy - main routine; checks run parameters
1725 # *process_all_files - main loop to process all files; *THIS LAYER
1726 # process_filter_layer - do any pre and post processing;
1727 # process_iteration_layer - handle any iterations on formatting
1728 # process_single_case - solves one formatting problem
1730 my $rOpts = $self->[_rOpts_];
1731 my $dot = $self->[_file_extension_separator_];
1732 my $diagnostics_object = $self->[_diagnostics_object_];
1733 my $line_separator_default = $self->[_line_separator_default_];
1735 my $destination_stream = $rinput_hash->{'destination'};
1736 my $errorfile_stream = $rinput_hash->{'errorfile'};
1737 my $logfile_stream = $rinput_hash->{'logfile'};
1738 my $teefile_stream = $rinput_hash->{'teefile'};
1739 my $debugfile_stream = $rinput_hash->{'debugfile'};
1740 my $source_stream = $rinput_hash->{'source'};
1741 my $stderr_stream = $rinput_hash->{'stderr'};
1743 my $number_of_files = @{$rfiles};
1744 while ( my $input_file = shift @{$rfiles} ) {
1747 my @input_file_stat;
1750 #--------------------------
1751 # prepare this input stream
1752 #--------------------------
1753 if ($source_stream) {
1754 $fileroot = "perltidy";
1755 $display_name = "<source_stream>";
1757 # If the source is from an array or string, then .LOG output
1758 # is only possible if a logfile stream is specified. This prevents
1759 # unexpected perltidy.LOG files.
1760 if ( !defined($logfile_stream) ) {
1761 $logfile_stream = Perl::Tidy::DevNull->new();
1763 # Likewise for .TEE and .DEBUG output
1765 if ( !defined($teefile_stream) ) {
1766 $teefile_stream = Perl::Tidy::DevNull->new();
1768 if ( !defined($debugfile_stream) ) {
1769 $debugfile_stream = Perl::Tidy::DevNull->new();
1772 elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN
1773 $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc
1774 $display_name = "<stdin>";
1775 $in_place_modify = 0;
1778 $fileroot = $input_file;
1779 $display_name = $input_file;
1780 unless ( -e $input_file ) {
1782 # file doesn't exist - check for a file glob
1783 if ( $input_file =~ /([\?\*\[\{])/ ) {
1785 # Windows shell may not remove quotes, so do it
1786 my $input_file = $input_file;
1787 if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
1788 if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
1789 my $pattern = fileglob_to_re($input_file);
1791 if ( opendir( $dh, './' ) ) {
1793 grep { /$pattern/ && !-d } readdir($dh);
1795 next unless (@files);
1796 unshift @{$rfiles}, @files;
1800 Warn("skipping file: '$input_file': no matches found\n");
1804 unless ( -f $input_file ) {
1805 Warn("skipping file: $input_file: not a regular file\n");
1809 # As a safety precaution, skip zero length files.
1810 # If for example a source file got clobbered somehow,
1811 # the old .tdy or .bak files might still exist so we
1812 # shouldn't overwrite them with zero length files.
1813 unless ( -s $input_file ) {
1814 Warn("skipping file: $input_file: Zero size\n");
1818 # And avoid formatting extremely large files. Since perltidy reads
1819 # files into memory, trying to process an extremely large file
1820 # could cause system problems.
1821 my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 );
1822 if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) {
1823 $size_in_mb = sprintf( "%0.1f", $size_in_mb );
1825 "skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n"
1830 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
1831 Warn("skipping file: $input_file: Non-text (override with -f)\n"
1836 # Input file must be writable for -b -bm='copy'. We must catch
1837 # this early to prevent encountering trouble after unlinking the
1839 if ( $in_place_modify && !-w $input_file ) {
1840 my $backup_method = $rOpts->{'backup-method'};
1841 if ( defined($backup_method) && $backup_method eq 'copy' ) {
1843 "skipping file '$input_file' for -b option: file reported as non-writable\n";
1848 # we should have a valid filename now
1849 $fileroot = $input_file;
1850 @input_file_stat = stat($input_file);
1852 if ( $OSNAME eq 'VMS' ) {
1853 ( $fileroot, $dot ) = check_vms_filename($fileroot);
1854 $self->[_file_extension_separator_] = $dot;
1857 # add option to change path here
1858 if ( defined( $rOpts->{'output-path'} ) ) {
1860 my ( $base, $old_path ) = fileparse($fileroot);
1861 my $new_path = $rOpts->{'output-path'};
1862 unless ( -d $new_path ) {
1863 unless ( mkdir $new_path, 0777 ) {
1864 Die("unable to create directory $new_path: $ERRNO\n");
1867 my $path = $new_path;
1868 $fileroot = catfile( $path, $base );
1869 unless ($fileroot) {
1871 ------------------------------------------------------------------------
1872 Problem combining $new_path and $base to make a filename; check -opath
1873 ------------------------------------------------------------------------
1879 # Skip files with same extension as the output files because
1880 # this can lead to a messy situation with files like
1881 # script.tdy.tdy.tdy ... or worse problems ... when you
1882 # rerun perltidy over and over with wildcard input.
1885 && ( $input_file =~ /$forbidden_file_extensions/
1886 || $input_file eq 'DIAGNOSTICS' )
1889 Warn("skipping file: $input_file: wrong extension\n");
1893 # copy source to a string buffer, decoding from utf8 if necessary
1898 $encoding_log_message,
1901 ) = $self->get_decoded_string_buffer( $input_file, $display_name,
1902 $rpending_logfile_message );
1904 # Skip this file on any error
1905 next if ( !defined($buf) );
1907 # Register this file name with the Diagnostics package, if any.
1908 $diagnostics_object->set_input_file($input_file)
1909 if $diagnostics_object;
1911 # OK: the (possibly decoded) input is now in string $buf. We just need
1912 # to to prepare the output and error logger before formatting it.
1914 #--------------------------
1915 # prepare the output stream
1916 #--------------------------
1917 my $output_file = undef;
1918 my $output_name = EMPTY_STRING;
1919 my $actual_output_extension;
1921 if ( $rOpts->{'outfile'} ) {
1923 if ( $number_of_files <= 1 ) {
1925 if ( $rOpts->{'standard-output'} ) {
1926 my $saw_pbp = $self->[_saw_pbp_];
1927 my $msg = "You may not use -o and -st together";
1928 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1931 elsif ($destination_stream) {
1933 "You may not specify a destination array and -o together\n"
1936 elsif ( defined( $rOpts->{'output-path'} ) ) {
1937 Die("You may not specify -o and -opath together\n");
1939 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
1940 Die("You may not specify -o and -oext together\n");
1942 $output_file = $rOpts->{outfile};
1943 $output_name = $output_file;
1945 # make sure user gives a file name after -o
1946 if ( $output_file =~ /^-/ ) {
1947 Die("You must specify a valid filename after -o\n");
1950 # do not overwrite input file with -o
1951 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
1952 Die("Use 'perltidy -b $input_file' to modify in-place\n");
1956 Die("You may not use -o with more than one input file\n");
1959 elsif ( $rOpts->{'standard-output'} ) {
1960 if ($destination_stream) {
1961 my $saw_pbp = $self->[_saw_pbp_];
1963 "You may not specify a destination array and -st together\n";
1964 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
1968 $output_name = "<stdout>";
1970 if ( $number_of_files <= 1 ) {
1973 Die("You may not use -st with more than one input file\n");
1976 elsif ($destination_stream) {
1978 $output_file = $destination_stream;
1979 $output_name = "<destination_stream>";
1981 elsif ($source_stream) { # source but no destination goes to stdout
1983 $output_name = "<stdout>";
1985 elsif ( $input_file eq '-' ) {
1987 $output_name = "<stdout>";
1990 if ($in_place_modify) {
1992 # Send output to a temporary array buffer. This will
1993 # allow efficient copying back to the input by
1994 # sub backup_and_modify_in_place, below.
1996 $output_file = \@tmp_buff;
1997 $output_name = $display_name;
2000 $actual_output_extension = $output_extension;
2001 $output_file = $fileroot . $output_extension;
2002 $output_name = $output_file;
2006 $rstatus->{'file_count'} += 1;
2007 $rstatus->{'output_name'} = $output_name;
2008 $rstatus->{'iteration_count'} = 0;
2009 $rstatus->{'converged'} = 0;
2011 #------------------------------------------
2012 # initialize the error logger for this file
2013 #------------------------------------------
2014 my $warning_file = $fileroot . $dot . "ERR";
2015 if ($errorfile_stream) { $warning_file = $errorfile_stream }
2016 my $log_file = $fileroot . $dot . "LOG";
2017 if ($logfile_stream) { $log_file = $logfile_stream }
2019 # The logger object handles warning messages, logfile messages,
2020 # and can supply basic run information to lower level routines.
2021 my $logger_object = Perl::Tidy::Logger->new(
2023 log_file => $log_file,
2024 warning_file => $warning_file,
2025 fh_stderr => $fh_stderr,
2026 display_name => $display_name,
2027 is_encoded_data => $is_encoded_data,
2029 $logger_object->write_logfile_entry($logfile_header);
2030 $logger_object->write_logfile_entry($encoding_log_message)
2031 if $encoding_log_message;
2033 # Now we can add any pending messages to the log
2034 if ( ${$rpending_logfile_message} ) {
2035 $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
2037 if ( ${$rpending_complaint} ) {
2038 $logger_object->complain( ${$rpending_complaint} );
2041 # Use input line endings if requested
2042 my $line_separator = $line_separator_default;
2043 if ( $rOpts->{'preserve-line-endings'} ) {
2044 my $ls_input = find_input_line_ending($input_file);
2045 if ( defined($ls_input) ) { $line_separator = $ls_input }
2048 # additional parameters needed by lower level routines
2049 $self->[_actual_output_extension_] = $actual_output_extension;
2050 $self->[_debugfile_stream_] = $debugfile_stream;
2051 $self->[_decoded_input_as_] = $decoded_input_as;
2052 $self->[_destination_stream_] = $destination_stream;
2053 $self->[_display_name_] = $display_name;
2054 $self->[_fileroot_] = $fileroot;
2055 $self->[_is_encoded_data_] = $is_encoded_data;
2056 $self->[_length_function_] = $length_function;
2057 $self->[_line_separator_] = $line_separator;
2058 $self->[_logger_object_] = $logger_object;
2059 $self->[_output_file_] = $output_file;
2060 $self->[_teefile_stream_] = $teefile_stream;
2061 $self->[_input_copied_verbatim_] = 0;
2062 $self->[_input_output_difference_] = 1; ## updated later if -b used
2064 #----------------------------------------------------------
2065 # Do all formatting of this buffer.
2066 # Results will go to the selected output file or streams(s)
2067 #----------------------------------------------------------
2068 $self->process_filter_layer($buf);
2070 #--------------------------------------------------
2071 # Handle the -b option (backup and modify in-place)
2072 #--------------------------------------------------
2073 if ($in_place_modify) {
2075 # For -b option, leave the file unchanged if a severe error caused
2076 # formatting to be skipped. Otherwise we will overwrite any backup.
2077 if ( !$self->[_input_copied_verbatim_] ) {
2079 my $backup_method = $rOpts->{'backup-method'};
2081 # Option 1, -bm='copy': uses newer version in which original is
2082 # copied to the backup and rewritten; see git #103.
2083 if ( defined($backup_method) && $backup_method eq 'copy' ) {
2084 $self->backup_method_copy(
2085 $input_file, $output_file,
2086 $backup_extension, $delete_backup
2090 # Option 2, -bm='move': uses older version, where original is
2091 # moved to the backup and formatted output goes to a new file.
2093 $self->backup_method_move(
2094 $input_file, $output_file,
2095 $backup_extension, $delete_backup
2099 $output_file = $input_file;
2102 #-------------------------------------------------------------------
2103 # Otherwise set output file ownership and permissions if appropriate
2104 #-------------------------------------------------------------------
2105 elsif ( $output_file && -f $output_file && !-l $output_file ) {
2106 if (@input_file_stat) {
2107 if ( $rOpts->{'format'} eq 'tidy' ) {
2108 $self->set_output_file_permissions( $output_file,
2109 \@input_file_stat, $in_place_modify );
2112 # else use default permissions for html and any other format
2116 $logger_object->finish()
2118 } ## end of main loop to process all files
2121 } ## end sub process_all_files
2123 sub process_filter_layer {
2125 my ( $self, $buf ) = @_;
2127 # This is the filter layer of processing.
2128 # Do all requested formatting on the string '$buf', including any
2129 # pre- and post-processing with filters.
2130 # Store the results in the selected output file(s) or stream(s).
2132 # Total formatting is done with these layers of subroutines:
2133 # perltidy - main routine; checks run parameters
2134 # process_all_files - main loop to process all files;
2135 # *process_filter_layer - do any pre and post processing; *THIS LAYER
2136 # process_iteration_layer - handle any iterations on formatting
2137 # process_single_case - solves one formatting problem
2139 # Data Flow in this layer:
2141 # -> optional prefilter operation
2142 # -> [ formatting by sub process_iteration_layer ]
2143 # -> ( optional postfilter_buffer for postfilter, other operations )
2144 # -> ( optional destination_buffer for encoding )
2145 # -> final sink_object
2147 # What is done based on format type:
2148 # utf8 decoding is done for all format types
2149 # prefiltering is applied to all format types
2150 # - because it may be needed to get through the tokenizer
2151 # postfiltering is only done for format='tidy'
2152 # - might cause problems operating on html text
2153 # encoding of decoded output is only done for format='tidy'
2154 # - because html does its own encoding; user formatter does what it wants
2156 my $rOpts = $self->[_rOpts_];
2157 my $is_encoded_data = $self->[_is_encoded_data_];
2158 my $logger_object = $self->[_logger_object_];
2159 my $output_file = $self->[_output_file_];
2160 my $user_formatter = $self->[_user_formatter_];
2161 my $destination_stream = $self->[_destination_stream_];
2162 my $prefilter = $self->[_prefilter_];
2163 my $postfilter = $self->[_postfilter_];
2164 my $decoded_input_as = $self->[_decoded_input_as_];
2165 my $line_separator = $self->[_line_separator_];
2167 my $remove_terminal_newline =
2168 !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/;
2170 # vars for postfilter, if used
2171 my $use_postfilter_buffer;
2172 my $postfilter_buffer;
2174 # vars for destination buffer, if used
2175 my $destination_buffer;
2176 my $use_destination_buffer;
2177 my $encode_destination_buffer;
2179 # vars for iterations, if done
2182 # vars for checking assertions, if needed
2184 my $saved_input_buf;
2186 my $ref_destination_stream = ref($destination_stream);
2188 # Setup vars for postfilter, destination buffer, assertions and sink object
2189 # if needed. These are only used for 'tidy' formatting.
2190 if ( $rOpts->{'format'} eq 'tidy' ) {
2192 # evaluate MD5 sum of input file, if needed, before any prefilter
2193 if ( $rOpts->{'assert-tidy'}
2194 || $rOpts->{'assert-untidy'}
2195 || $rOpts->{'backup-and-modify-in-place'} )
2197 $digest_input = $md5_hex->($buf);
2198 $saved_input_buf = $buf;
2201 #-----------------------
2202 # Setup postfilter buffer
2203 #-----------------------
2204 # If we need access to the output for filtering or checking assertions
2205 # before writing to its ultimate destination, then we will send it
2206 # to a temporary buffer. The variables are:
2207 # $postfilter_buffer = the buffer to capture the output
2208 # $use_postfilter_buffer = is a postfilter buffer used?
2209 # These are used below, just after iterations are made.
2210 $use_postfilter_buffer =
2212 || $remove_terminal_newline
2213 || $rOpts->{'assert-tidy'}
2214 || $rOpts->{'assert-untidy'}
2215 || $rOpts->{'backup-and-modify-in-place'};
2217 #-------------------------
2218 # Setup destination_buffer
2219 #-------------------------
2220 # If the final output destination is not a file, then we might need to
2221 # encode the result at the end of processing. So in this case we will
2222 # send the output to a temporary buffer.
2223 # The key variables are:
2224 # $destination_buffer - receives the formatted output
2225 # $use_destination_buffer - is $destination_buffer used?
2226 # $encode_destination_buffer - encode $destination_buffer?
2227 # These are used by sub 'copy_buffer_to_destination', below
2229 if ($ref_destination_stream) {
2230 $use_destination_buffer = 1;
2231 $output_file = \$destination_buffer;
2232 $self->[_output_file_] = $output_file;
2234 # Strings and arrays use special encoding rules
2235 if ( $ref_destination_stream eq 'SCALAR'
2236 || $ref_destination_stream eq 'ARRAY' )
2238 $encode_destination_buffer =
2239 $rOpts->{'encode-output-strings'} && $decoded_input_as;
2242 # An object with a print method will use file encoding rules
2243 elsif ( $ref_destination_stream->can('print') ) {
2244 $encode_destination_buffer = $is_encoded_data;
2248 ------------------------------------------------------------------------
2249 No 'print' method is defined for object of class '$ref_destination_stream'
2250 Please check your call to Perl::Tidy::perltidy. Trace follows.
2251 ------------------------------------------------------------------------
2256 #-------------------------------------------
2257 # Make a sink object for the iteration phase
2258 #-------------------------------------------
2259 $sink_object = Perl::Tidy::LineSink->new(
2260 output_file => $use_postfilter_buffer
2261 ? \$postfilter_buffer
2263 line_separator => $line_separator,
2264 is_encoded_data => $is_encoded_data,
2268 #-----------------------------------------------------------------------
2269 # Apply any prefilter. The prefilter is a code reference that will be
2270 # applied to the source before tokenizing. Note that we are doing this
2271 # for all format types ('tidy', 'html', 'user') because it may be needed
2272 # to avoid tokenization errors.
2273 #-----------------------------------------------------------------------
2274 $buf = $prefilter->($buf) if $prefilter;
2276 #----------------------------------------------------------------------
2277 # Format contents of string '$buf', iterating if requested.
2278 # For 'tidy', formatted result will be written to '$sink_object'
2279 # For 'html' and 'user', result goes directly to its ultimate destination.
2280 #----------------------------------------------------------------------
2281 $self->process_iteration_layer( $buf, $sink_object );
2283 #--------------------------------
2284 # Do postfilter buffer processing
2285 #--------------------------------
2286 if ($use_postfilter_buffer) {
2288 my $sink_object_post = Perl::Tidy::LineSink->new(
2289 output_file => $output_file,
2290 line_separator => $line_separator,
2291 is_encoded_data => $is_encoded_data,
2294 #----------------------------------------------------------------------
2295 # Apply any postfilter. The postfilter is a code reference that will be
2296 # applied to the source after tidying.
2297 #----------------------------------------------------------------------
2300 ? $postfilter->($postfilter_buffer)
2301 : $postfilter_buffer;
2303 if ( defined($digest_input) ) {
2304 my $digest_output = $md5_hex->($buf_post);
2305 $self->[_input_output_difference_] =
2306 $digest_output ne $digest_input;
2309 # Check if file changed if requested, but only after any postfilter
2310 if ( $rOpts->{'assert-tidy'} ) {
2311 if ( $self->[_input_output_difference_] ) {
2313 compare_string_buffers( $saved_input_buf, $buf_post,
2315 $logger_object->warning(<<EOM);
2316 assertion failure: '--assert-tidy' is set but output differs from input
2318 $logger_object->interrupt_logfile();
2319 $logger_object->warning( $diff_msg . "\n" );
2320 $logger_object->resume_logfile();
2324 if ( $rOpts->{'assert-untidy'} ) {
2325 if ( !$self->[_input_output_difference_] ) {
2326 $logger_object->warning(
2327 "assertion failure: '--assert-untidy' is set but output equals input\n"
2332 my $source_object = Perl::Tidy::LineSource->new(
2333 input_file => \$buf_post,
2337 # Copy the filtered buffer to the final destination
2338 if ( !$remove_terminal_newline ) {
2339 while ( my $line = $source_object->get_line() ) {
2340 $sink_object_post->write_line($line);
2345 # Copy the filtered buffer but remove the newline char from the
2348 while ( my $next_line = $source_object->get_line() ) {
2349 $sink_object_post->write_line($line) if ($line);
2353 $sink_object_post->set_line_separator(undef);
2355 $sink_object_post->write_line($line);
2358 $sink_object_post->close_output_file();
2359 $source_object->close_input_file();
2362 #--------------------------------------------------------
2363 # Do destination buffer processing, encoding if required.
2364 #--------------------------------------------------------
2365 if ($use_destination_buffer) {
2366 $self->copy_buffer_to_destination( $destination_buffer,
2367 $destination_stream, $encode_destination_buffer );
2371 # output went to a file in 'tidy' mode...
2372 if ( $is_encoded_data && $rOpts->{'format'} eq 'tidy' ) {
2373 $rstatus->{'output_encoded_as'} = 'UTF-8';
2377 # The final formatted result should now be in the selected output file(s)
2381 } ## end sub process_filter_layer
2383 sub process_iteration_layer {
2385 my ( $self, $buf, $sink_object ) = @_;
2387 # This is the iteration layer of processing.
2388 # Do all formatting, iterating if requested, on the source string $buf.
2389 # Output depends on format type:
2390 # For 'tidy' formatting, output goes to sink object
2391 # For 'html' formatting, output goes to the ultimate destination
2392 # For 'user' formatting, user formatter handles output
2394 # Total formatting is done with these layers of subroutines:
2395 # perltidy - main routine; checks run parameters
2396 # process_all_files - main loop to process all files;
2397 # process_filter_layer - do any pre and post processing
2398 # *process_iteration_layer - do any iterations on formatting; *THIS LAYER
2399 # process_single_case - solves one formatting problem
2401 # Data Flow in this layer:
2402 # $buf -> [ loop over iterations ] -> $sink_object
2404 # Only 'tidy' formatting can use multiple iterations.
2406 my $diagnostics_object = $self->[_diagnostics_object_];
2407 my $display_name = $self->[_display_name_];
2408 my $fileroot = $self->[_fileroot_];
2409 my $is_encoded_data = $self->[_is_encoded_data_];
2410 my $length_function = $self->[_length_function_];
2411 my $line_separator = $self->[_line_separator_];
2412 my $logger_object = $self->[_logger_object_];
2413 my $rOpts = $self->[_rOpts_];
2414 my $tabsize = $self->[_tabsize_];
2415 my $user_formatter = $self->[_user_formatter_];
2417 # create a source object for the buffer
2418 my $source_object = Perl::Tidy::LineSource->new(
2419 input_file => \$buf,
2423 # make a debugger object if requested
2424 my $debugger_object;
2425 if ( $rOpts->{DEBUG} ) {
2426 my $debug_file = $self->[_debugfile_stream_]
2427 || $fileroot . $self->make_file_extension('DEBUG');
2429 Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data );
2432 # make a tee file handle if requested
2434 if ( $rOpts->{'tee-pod'}
2435 || $rOpts->{'tee-block-comments'}
2436 || $rOpts->{'tee-side-comments'} )
2438 my $tee_file = $self->[_teefile_stream_]
2439 || $fileroot . $self->make_file_extension('TEE');
2440 ( $fh_tee, my $tee_filename ) =
2441 Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data );
2443 Warn("couldn't open TEE file $tee_file: $ERRNO\n");
2447 # vars for iterations and convergence test
2448 my $max_iterations = 1;
2449 my $convergence_log_message;
2450 my $do_convergence_test;
2453 # Only 'tidy' formatting can use multiple iterations
2454 if ( $rOpts->{'format'} eq 'tidy' ) {
2456 # check iteration count and quietly fix if necessary:
2457 # - iterations option only applies to code beautification mode
2458 # - the convergence check should stop most runs on iteration 2, and
2459 # virtually all on iteration 3. But we'll allow up to 6.
2460 $max_iterations = $rOpts->{'iterations'};
2461 if ( !defined($max_iterations)
2462 || $max_iterations <= 0 )
2464 $max_iterations = 1;
2466 elsif ( $max_iterations > 6 ) {
2467 $max_iterations = 6;
2470 # get starting MD5 sum for convergence test
2471 if ( $max_iterations > 1 ) {
2472 $do_convergence_test = 1;
2473 my $digest = $md5_hex->($buf);
2474 $saw_md5{$digest} = 0;
2478 # save objects to allow redirecting output during iterations
2479 my $sink_object_final = $sink_object;
2480 my $logger_object_final = $logger_object;
2481 my $iteration_of_formatter_convergence;
2483 #---------------------
2484 # Loop over iterations
2485 #---------------------
2486 foreach my $iter ( 1 .. $max_iterations ) {
2488 $rstatus->{'iteration_count'} += 1;
2490 # send output stream to temp buffers until last iteration
2492 if ( $iter < $max_iterations ) {
2493 $sink_object = Perl::Tidy::LineSink->new(
2494 output_file => \$sink_buffer,
2495 line_separator => $line_separator,
2496 is_encoded_data => $is_encoded_data,
2500 $sink_object = $sink_object_final;
2503 # Save logger, debugger and tee output only on pass 1 because:
2504 # (1) line number references must be to the starting
2505 # source, not an intermediate result, and
2506 # (2) we need to know if there are errors so we can stop the
2507 # iterations early if necessary.
2508 # (3) the tee option only works on first pass if comments are also
2512 $debugger_object->close_debug_file() if ($debugger_object);
2513 $fh_tee->close() if ($fh_tee);
2515 $debugger_object = undef;
2516 $logger_object = undef;
2520 #---------------------------------
2521 # create a formatter for this file
2522 #---------------------------------
2526 if ($user_formatter) {
2527 $formatter = $user_formatter;
2529 elsif ( $rOpts->{'format'} eq 'html' ) {
2531 my $html_toc_extension =
2532 $self->make_file_extension( $rOpts->{'html-toc-extension'},
2535 my $html_src_extension =
2536 $self->make_file_extension( $rOpts->{'html-src-extension'},
2539 $formatter = Perl::Tidy::HtmlWriter->new(
2540 input_file => $fileroot,
2541 html_file => $self->[_output_file_],
2542 extension => $self->[_actual_output_extension_],
2543 html_toc_extension => $html_toc_extension,
2544 html_src_extension => $html_src_extension,
2547 elsif ( $rOpts->{'format'} eq 'tidy' ) {
2548 $formatter = Perl::Tidy::Formatter->new(
2549 logger_object => $logger_object,
2550 diagnostics_object => $diagnostics_object,
2551 sink_object => $sink_object,
2552 length_function => $length_function,
2553 is_encoded_data => $is_encoded_data,
2558 Die("I don't know how to do -format=$rOpts->{'format'}\n");
2561 unless ($formatter) {
2562 Die("Unable to continue with $rOpts->{'format'} formatting\n");
2565 #-----------------------------------
2566 # create the tokenizer for this file
2567 #-----------------------------------
2568 my $tokenizer = Perl::Tidy::Tokenizer->new(
2569 source_object => $source_object,
2570 logger_object => $logger_object,
2571 debugger_object => $debugger_object,
2572 diagnostics_object => $diagnostics_object,
2573 tabsize => $tabsize,
2576 starting_level => $rOpts->{'starting-indentation-level'},
2577 indent_columns => $rOpts->{'indent-columns'},
2578 look_for_hash_bang => $rOpts->{'look-for-hash-bang'},
2579 look_for_autoloader => $rOpts->{'look-for-autoloader'},
2580 look_for_selfloader => $rOpts->{'look-for-selfloader'},
2581 trim_qw => $rOpts->{'trim-qw'},
2582 extended_syntax => $rOpts->{'extended-syntax'},
2584 continuation_indentation => $rOpts->{'continuation-indentation'},
2585 outdent_labels => $rOpts->{'outdent-labels'},
2588 #---------------------------------
2589 # do processing for this iteration
2590 #---------------------------------
2591 $self->process_single_case( $tokenizer, $formatter );
2593 #-----------------------------------------
2594 # close the input source and report errors
2595 #-----------------------------------------
2596 $source_object->close_input_file();
2598 # see if the formatter is converged
2599 if ( $max_iterations > 1
2600 && !defined($iteration_of_formatter_convergence)
2601 && $formatter->can('get_convergence_check') )
2603 if ( $formatter->get_convergence_check() ) {
2604 $iteration_of_formatter_convergence = $iter;
2605 $rstatus->{'converged'} = 1;
2609 # line source for next iteration (if any) comes from the current
2610 # temporary output buffer
2611 if ( $iter < $max_iterations ) {
2613 $sink_object->close_output_file();
2614 $source_object = Perl::Tidy::LineSource->new(
2615 input_file => \$sink_buffer,
2619 # stop iterations if errors or converged
2620 my $stop_now = $self->[_input_copied_verbatim_];
2621 $stop_now ||= $tokenizer->get_unexpected_error_count();
2622 my $stopping_on_error = $stop_now;
2624 $convergence_log_message = <<EOM;
2625 Stopping iterations because of severe errors.
2628 elsif ($do_convergence_test) {
2630 # stop if the formatter has converged
2631 $stop_now ||= defined($iteration_of_formatter_convergence);
2633 my $digest = $md5_hex->($sink_buffer);
2634 if ( !defined( $saw_md5{$digest} ) ) {
2635 $saw_md5{$digest} = $iter;
2639 # Deja vu, stop iterating
2641 my $iterm = $iter - 1;
2642 if ( $saw_md5{$digest} != $iterm ) {
2644 # Blinking (oscillating) between two or more stable
2645 # end states. This is unlikely to occur with normal
2646 # parameters, but it can occur in stress testing
2647 # with extreme parameter values, such as very short
2648 # maximum line lengths. We want to catch and fix
2649 # them when they happen.
2650 $rstatus->{'blinking'} = 1;
2651 $convergence_log_message = <<EOM;
2652 BLINKER. Output for iteration $iter same as for $saw_md5{$digest}.
2654 $stopping_on_error ||= $convergence_log_message;
2656 && print STDERR $convergence_log_message;
2657 $diagnostics_object->write_diagnostics(
2658 $convergence_log_message)
2659 if $diagnostics_object;
2661 # Uncomment to search for blinking states
2662 # Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" );
2666 $convergence_log_message = <<EOM;
2667 Converged. Output for iteration $iter same as for iter $iterm.
2669 $diagnostics_object->write_diagnostics(
2670 $convergence_log_message)
2671 if $diagnostics_object && $iterm > 2;
2672 $rstatus->{'converged'} = 1;
2675 } ## end if ($do_convergence_test)
2681 if ( defined($iteration_of_formatter_convergence) ) {
2683 # This message cannot appear unless the formatter
2684 # convergence test above is temporarily skipped for
2686 if ( $iteration_of_formatter_convergence < $iter - 1 ) {
2688 "STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n";
2691 elsif ( !$stopping_on_error ) {
2693 "STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n";
2697 # we are stopping the iterations early;
2698 # copy the output stream to its final destination
2699 $sink_object = $sink_object_final;
2700 while ( my $line = $source_object->get_line() ) {
2701 $sink_object->write_line($line);
2703 $source_object->close_input_file();
2706 } ## end if ( $iter < $max_iterations)
2707 } ## end loop over iterations for one source file
2709 $sink_object->close_output_file() if $sink_object;
2710 $debugger_object->close_debug_file() if $debugger_object;
2711 $fh_tee->close() if $fh_tee;
2713 # leave logger object open for additional messages
2714 $logger_object = $logger_object_final;
2715 $logger_object->write_logfile_entry($convergence_log_message)
2716 if $convergence_log_message;
2720 } ## end sub process_iteration_layer
2722 sub process_single_case {
2724 # run the formatter on a single defined case
2725 my ( $self, $tokenizer, $formatter ) = @_;
2727 # Total formatting is done with these layers of subroutines:
2728 # perltidy - main routine; checks run parameters
2729 # process_all_files - main loop to process all files;
2730 # process_filter_layer - do any pre and post processing;
2731 # process_iteration_layer - do any iterations on formatting
2732 # *process_single_case - solve one formatting problem; *THIS LAYER
2734 while ( my $line = $tokenizer->get_line() ) {
2735 $formatter->write_line($line);
2738 # user-defined formatters are possible, and may not have a
2739 # sub 'finish_formatting', so we have to check
2740 if ( $formatter->can('finish_formatting') ) {
2741 my $severe_error = $tokenizer->report_tokenization_errors();
2742 my $verbatim = $formatter->finish_formatting($severe_error);
2743 $self->[_input_copied_verbatim_] = $verbatim;
2747 } ## end sub process_single_case
2749 sub copy_buffer_to_destination {
2751 my ( $self, $destination_buffer, $destination_stream,
2752 $encode_destination_buffer )
2755 # Copy $destination_buffer to the final $destination_stream,
2756 # encoding if the flag $encode_destination_buffer is true.
2759 # $destination_buffer -> [ encode? ] -> $destination_stream
2761 $rstatus->{'output_encoded_as'} = EMPTY_STRING;
2763 if ($encode_destination_buffer) {
2768 Encode::encode( "UTF-8", $destination_buffer,
2769 Encode::FB_CROAK | Encode::LEAVE_SRC );
2776 "Error attempting to encode output string ref; encoding not done\n"
2780 $destination_buffer = $encoded_buffer;
2781 $rstatus->{'output_encoded_as'} = 'UTF-8';
2785 # Send data for SCALAR, ARRAY & OBJ refs to its final destination
2786 if ( ref($destination_stream) eq 'SCALAR' ) {
2787 ${$destination_stream} = $destination_buffer;
2789 elsif ($destination_buffer) {
2790 my @lines = split /^/, $destination_buffer;
2791 if ( ref($destination_stream) eq 'ARRAY' ) {
2792 @{$destination_stream} = @lines;
2795 # destination stream must be an object with print method
2797 foreach my $line (@lines) {
2798 $destination_stream->print($line);
2800 my $ref_destination_stream = ref($destination_stream);
2801 if ( $ref_destination_stream->can('close') ) {
2802 $destination_stream->close();
2808 # Empty destination buffer not going to a string ... could
2809 # happen for example if user deleted all pod or comments
2812 } ## end sub copy_buffer_to_destination
2814 } ## end of closure for sub perltidy
2818 # Given two strings, return
2819 # $diff_marker = a string with carat (^) symbols indicating differences
2820 # $pos1 = character position of first difference; pos1=-1 if no difference
2822 # Form exclusive or of the strings, which has null characters where strings
2823 # have same common characters so non-null characters indicate character
2825 my ( $s1, $s2 ) = @_;
2826 my $diff_marker = EMPTY_STRING;
2829 if ( defined($s1) && defined($s2) ) {
2831 my $mask = $s1 ^ $s2;
2833 while ( $mask =~ /[^\0]/g ) {
2835 my $pos_last = $pos;
2836 $pos = $LAST_MATCH_START[0];
2837 if ( $count == 1 ) { $pos1 = $pos; }
2838 $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^';
2840 # we could continue to mark all differences, but there is no point
2844 return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker;
2845 } ## end sub line_diff
2847 sub compare_string_buffers {
2849 # Compare input and output string buffers and return a brief text
2850 # description of the first difference.
2851 my ( $bufi, $bufo, $is_encoded_data ) = @_;
2853 my $leni = length($bufi);
2854 my $leno = defined($bufo) ? length($bufo) : 0;
2856 "Input file length is $leni chars\nOutput file length is $leno chars\n";
2857 return $msg unless $leni && $leno;
2859 my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data );
2860 my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data );
2861 return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen
2862 my ( $linei, $lineo );
2863 my ( $counti, $counto ) = ( 0, 0 );
2864 my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 );
2865 my $truncate = sub {
2866 my ( $str, $lenmax ) = @_;
2867 if ( length($str) > $lenmax ) {
2868 $str = substr( $str, 0, $lenmax ) . "...";
2874 $last_nonblank_line = $linei;
2875 $last_nonblank_count = $counti;
2877 $linei = $fhi->getline();
2878 $lineo = $fho->getline();
2880 # compare chomp'ed lines
2881 if ( defined($linei) ) { $counti++; chomp $linei }
2882 if ( defined($lineo) ) { $counto++; chomp $lineo }
2884 # see if one or both ended before a difference
2885 last unless ( defined($linei) && defined($lineo) );
2887 next if ( $linei eq $lineo );
2890 my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo );
2891 my $reason = "Files first differ at character $pos1 of line $counti";
2893 my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING );
2894 if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; }
2895 if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; }
2896 if ( $leading_ws_i ne $leading_ws_o ) {
2897 $reason .= "; leading whitespace differs";
2898 if ( $leading_ws_i =~ /\t/ ) {
2899 $reason .= "; input has tab char";
2903 my ( $trailing_ws_i, $trailing_ws_o ) =
2904 ( EMPTY_STRING, EMPTY_STRING );
2905 if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; }
2906 if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; }
2907 if ( $trailing_ws_i ne $trailing_ws_o ) {
2908 $reason .= "; trailing whitespace differs";
2911 $msg .= $reason . "\n";
2913 # limit string display length
2915 my $drop = $pos1 - 40;
2916 $linei = "..." . substr( $linei, $drop );
2917 $lineo = "..." . substr( $lineo, $drop );
2918 $line_diff = SPACE x 3 . substr( $line_diff, $drop );
2920 $linei = $truncate->( $linei, 72 );
2921 $lineo = $truncate->( $lineo, 72 );
2922 $last_nonblank_line = $truncate->( $last_nonblank_line, 72 );
2924 if ($last_nonblank_line) {
2926 $last_nonblank_count:$last_nonblank_line
2929 $line_diff = SPACE x ( 2 + length($counto) ) . $line_diff;
2938 # no line differences found, but one file may have fewer lines
2939 if ( $counti > $counto ) {
2941 Files initially match file but output file has fewer lines
2944 elsif ( $counti < $counto ) {
2946 Files initially match file but input file has fewer lines
2951 Text in lines of file match but checksums differ. Perhaps line endings differ.
2955 } ## end sub compare_string_buffers
2957 sub fileglob_to_re {
2959 # modified (corrected) from version in find2perl
2961 $x =~ s#([./^\$()])#\\$1#g; # escape special characters
2962 $x =~ s#\*#.*#g; # '*' -> '.*'
2963 $x =~ s#\?#.#g; # '?' -> '.'
2964 return "^$x\\z"; # match whole word
2965 } ## end sub fileglob_to_re
2967 sub make_logfile_header {
2968 my ( $rOpts, $config_file, $rraw_options, $Windows_type, $readable_options )
2971 # Note: the punctuation variable '$]' is not in older versions of
2972 # English.pm so leave it as is to avoid failing installation tests.
2974 "perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n";
2975 if ($Windows_type) {
2976 $msg .= "Windows type is $Windows_type\n";
2978 my $options_string = join( SPACE, @{$rraw_options} );
2981 $msg .= "Found Configuration File >>> $config_file \n";
2983 $msg .= "Configuration and command line parameters for this run:\n";
2984 $msg .= "$options_string\n";
2986 if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
2987 $rOpts->{'logfile'} = 1; # force logfile to be saved
2988 $msg .= "Final parameter set for this run\n";
2989 $msg .= "------------------------------------\n";
2991 $msg .= $readable_options;
2993 $msg .= "------------------------------------\n";
2995 $msg .= "To find error messages search for 'WARNING' with your editor\n";
2997 } ## end sub make_logfile_header
2999 sub generate_options {
3001 ######################################################################
3002 # Generate and return references to:
3003 # @option_string - the list of options to be passed to Getopt::Long
3004 # @defaults - the list of default options
3005 # %expansion - a hash showing how all abbreviations are expanded
3006 # %category - a hash giving the general category of each option
3007 # %option_range - a hash giving the valid ranges of certain options
3009 # Note: a few options are not documented in the man page and usage
3010 # message. This is because these are experimental or debug options and
3011 # may or may not be retained in future versions.
3013 # Here are the undocumented flags as far as I know. Any of them
3014 # may disappear at any time. They are mainly for fine-tuning
3017 # fll --> fuzzy-line-length # a trivial parameter which gets
3018 # turned off for the extrude option
3019 # which is mainly for debugging
3020 # scl --> short-concatenation-item-length # helps break at '.'
3021 # recombine # for debugging line breaks
3022 # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**]
3023 ######################################################################
3025 # here is a summary of the Getopt codes:
3026 # <none> does not take an argument
3027 # =s takes a mandatory string
3028 # :s takes an optional string (DO NOT USE - filenames will get eaten up)
3029 # =i takes a mandatory integer
3030 # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
3031 # ! does not take an argument and may be negated
3032 # i.e., -foo and -nofoo are allowed
3033 # a double dash signals the end of the options list
3035 #-----------------------------------------------
3036 # Define the option string passed to GetOptions.
3037 #-----------------------------------------------
3039 my @option_string = ();
3041 my %option_category = ();
3042 my %option_range = ();
3043 my $rexpansion = \%expansion;
3045 # names of categories in manual
3046 # leading integers will allow sorting
3047 my @category_name = (
3049 '1. Basic formatting options',
3050 '2. Code indentation control',
3051 '3. Whitespace control',
3052 '4. Comment controls',
3053 '5. Linebreak controls',
3054 '6. Controlling list formatting',
3055 '7. Retaining or ignoring existing line breaks',
3056 '8. Blank line control',
3057 '9. Other controls',
3059 '11. pod2html options',
3060 '12. Controlling HTML properties',
3064 # These options are parsed directly by perltidy:
3067 # However, they are included in the option set so that they will
3068 # be seen in the options dump.
3070 # These long option names have no abbreviations or are treated specially
3071 @option_string = qw(
3080 my $category = 13; # Debugging
3081 foreach (@option_string) {
3082 my $opt = $_; # must avoid changing the actual flag
3084 $option_category{$opt} = $category_name[$category];
3087 $category = 11; # HTML
3088 $option_category{html} = $category_name[$category];
3090 # routine to install and check options
3091 my $add_option = sub {
3092 my ( $long_name, $short_name, $flag ) = @_;
3093 push @option_string, $long_name . $flag;
3094 $option_category{$long_name} = $category_name[$category];
3096 if ( $expansion{$short_name} ) {
3097 my $existing_name = $expansion{$short_name}[0];
3099 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
3102 $expansion{$short_name} = [$long_name];
3103 if ( $flag eq '!' ) {
3104 my $nshort_name = 'n' . $short_name;
3105 my $nolong_name = 'no' . $long_name;
3106 if ( $expansion{$nshort_name} ) {
3107 my $existing_name = $expansion{$nshort_name}[0];
3109 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
3112 $expansion{$nshort_name} = [$nolong_name];
3118 # Install long option names which have a simple abbreviation.
3119 # Options with code '!' get standard negation ('no' for long names,
3120 # 'n' for abbreviations). Categories follow the manual.
3122 ###########################
3123 $category = 0; # I/O_Control
3124 ###########################
3125 $add_option->( 'backup-and-modify-in-place', 'b', '!' );
3126 $add_option->( 'backup-file-extension', 'bext', '=s' );
3127 $add_option->( 'backup-method', 'bm', '=s' );
3128 $add_option->( 'character-encoding', 'enc', '=s' );
3129 $add_option->( 'force-read-binary', 'f', '!' );
3130 $add_option->( 'format', 'fmt', '=s' );
3131 $add_option->( 'iterations', 'it', '=i' );
3132 $add_option->( 'logfile', 'log', '!' );
3133 $add_option->( 'logfile-gap', 'g', ':i' );
3134 $add_option->( 'outfile', 'o', '=s' );
3135 $add_option->( 'output-file-extension', 'oext', '=s' );
3136 $add_option->( 'output-path', 'opath', '=s' );
3137 $add_option->( 'profile', 'pro', '=s' );
3138 $add_option->( 'quiet', 'q', '!' );
3139 $add_option->( 'standard-error-output', 'se', '!' );
3140 $add_option->( 'standard-output', 'st', '!' );
3141 $add_option->( 'use-unicode-gcstring', 'gcs', '!' );
3142 $add_option->( 'warning-output', 'w', '!' );
3143 $add_option->( 'add-terminal-newline', 'atnl', '!' );
3145 # options which are both toggle switches and values moved here
3146 # to hide from tidyview (which does not show category 0 flags):
3147 # -ole moved here from category 1
3148 # -sil moved here from category 2
3149 $add_option->( 'output-line-ending', 'ole', '=s' );
3150 $add_option->( 'starting-indentation-level', 'sil', '=i' );
3152 ########################################
3153 $category = 1; # Basic formatting options
3154 ########################################
3155 $add_option->( 'check-syntax', 'syn', '!' );
3156 $add_option->( 'entab-leading-whitespace', 'et', '=i' );
3157 $add_option->( 'indent-columns', 'i', '=i' );
3158 $add_option->( 'maximum-line-length', 'l', '=i' );
3159 $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
3160 $add_option->( 'whitespace-cycle', 'wc', '=i' );
3161 $add_option->( 'perl-syntax-check-flags', 'pscf', '=s' );
3162 $add_option->( 'preserve-line-endings', 'ple', '!' );
3163 $add_option->( 'tabs', 't', '!' );
3164 $add_option->( 'default-tabsize', 'dt', '=i' );
3165 $add_option->( 'extended-syntax', 'xs', '!' );
3166 $add_option->( 'assert-tidy', 'ast', '!' );
3167 $add_option->( 'assert-untidy', 'asu', '!' );
3168 $add_option->( 'encode-output-strings', 'eos', '!' );
3169 $add_option->( 'sub-alias-list', 'sal', '=s' );
3170 $add_option->( 'grep-alias-list', 'gal', '=s' );
3171 $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' );
3172 $add_option->( 'use-feature', 'uf', '=s' );
3174 ########################################
3175 $category = 2; # Code indentation control
3176 ########################################
3177 $add_option->( 'continuation-indentation', 'ci', '=i' );
3178 $add_option->( 'extended-continuation-indentation', 'xci', '!' );
3179 $add_option->( 'line-up-parentheses', 'lp', '!' );
3180 $add_option->( 'extended-line-up-parentheses', 'xlp', '!' );
3181 $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' );
3182 $add_option->( 'line-up-parentheses-inclusion-list', 'lpil', '=s' );
3183 $add_option->( 'outdent-keyword-list', 'okwl', '=s' );
3184 $add_option->( 'outdent-keywords', 'okw', '!' );
3185 $add_option->( 'outdent-labels', 'ola', '!' );
3186 $add_option->( 'outdent-long-quotes', 'olq', '!' );
3187 $add_option->( 'indent-closing-brace', 'icb', '!' );
3188 $add_option->( 'closing-token-indentation', 'cti', '=i' );
3189 $add_option->( 'closing-paren-indentation', 'cpi', '=i' );
3190 $add_option->( 'closing-brace-indentation', 'cbi', '=i' );
3191 $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
3192 $add_option->( 'brace-left-and-indent', 'bli', '!' );
3193 $add_option->( 'brace-left-and-indent-list', 'blil', '=s' );
3194 $add_option->( 'brace-left-and-indent-exclusion-list', 'blixl', '=s' );
3196 ########################################
3197 $category = 3; # Whitespace control
3198 ########################################
3199 $add_option->( 'add-trailing-commas', 'atc', '!' );
3200 $add_option->( 'add-semicolons', 'asc', '!' );
3201 $add_option->( 'add-whitespace', 'aws', '!' );
3202 $add_option->( 'block-brace-tightness', 'bbt', '=i' );
3203 $add_option->( 'brace-tightness', 'bt', '=i' );
3204 $add_option->( 'delete-old-whitespace', 'dws', '!' );
3205 $add_option->( 'delete-repeated-commas', 'drc', '!' );
3206 $add_option->( 'delete-trailing-commas', 'dtc', '!' );
3207 $add_option->( 'delete-weld-interfering-commas', 'dwic', '!' );
3208 $add_option->( 'delete-semicolons', 'dsm', '!' );
3209 $add_option->( 'function-paren-vertical-alignment', 'fpva', '!' );
3210 $add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' );
3211 $add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' );
3212 $add_option->( 'logical-padding', 'lop', '!' );
3213 $add_option->( 'nospace-after-keyword', 'nsak', '=s' );
3214 $add_option->( 'nowant-left-space', 'nwls', '=s' );
3215 $add_option->( 'nowant-right-space', 'nwrs', '=s' );
3216 $add_option->( 'paren-tightness', 'pt', '=i' );
3217 $add_option->( 'space-after-keyword', 'sak', '=s' );
3218 $add_option->( 'space-for-semicolon', 'sfs', '!' );
3219 $add_option->( 'space-function-paren', 'sfp', '!' );
3220 $add_option->( 'space-keyword-paren', 'skp', '!' );
3221 $add_option->( 'space-terminal-semicolon', 'sts', '!' );
3222 $add_option->( 'square-bracket-tightness', 'sbt', '=i' );
3223 $add_option->( 'square-bracket-vertical-tightness', 'sbvt', '=i' );
3224 $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
3225 $add_option->( 'tight-secret-operators', 'tso', '!' );
3226 $add_option->( 'trim-qw', 'tqw', '!' );
3227 $add_option->( 'trim-pod', 'trp', '!' );
3228 $add_option->( 'want-left-space', 'wls', '=s' );
3229 $add_option->( 'want-right-space', 'wrs', '=s' );
3230 $add_option->( 'want-trailing-commas', 'wtc', '=s' );
3231 $add_option->( 'space-prototype-paren', 'spp', '=i' );
3232 $add_option->( 'valign-code', 'vc', '!' );
3233 $add_option->( 'valign-block-comments', 'vbc', '!' );
3234 $add_option->( 'valign-side-comments', 'vsc', '!' );
3235 $add_option->( 'valign-exclusion-list', 'vxl', '=s' );
3236 $add_option->( 'valign-inclusion-list', 'vil', '=s' );
3238 ########################################
3239 $category = 4; # Comment controls
3240 ########################################
3241 $add_option->( 'closing-side-comment-else-flag', 'csce', '=i' );
3242 $add_option->( 'closing-side-comment-interval', 'csci', '=i' );
3243 $add_option->( 'closing-side-comment-list', 'cscl', '=s' );
3244 $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
3245 $add_option->( 'closing-side-comment-prefix', 'cscp', '=s' );
3246 $add_option->( 'closing-side-comment-warnings', 'cscw', '!' );
3247 $add_option->( 'closing-side-comments', 'csc', '!' );
3248 $add_option->( 'closing-side-comments-balanced', 'cscb', '!' );
3249 $add_option->( 'code-skipping', 'cs', '!' );
3250 $add_option->( 'code-skipping-begin', 'csb', '=s' );
3251 $add_option->( 'code-skipping-end', 'cse', '=s' );
3252 $add_option->( 'format-skipping', 'fs', '!' );
3253 $add_option->( 'format-skipping-begin', 'fsb', '=s' );
3254 $add_option->( 'format-skipping-end', 'fse', '=s' );
3255 $add_option->( 'hanging-side-comments', 'hsc', '!' );
3256 $add_option->( 'indent-block-comments', 'ibc', '!' );
3257 $add_option->( 'indent-spaced-block-comments', 'isbc', '!' );
3258 $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' );
3259 $add_option->( 'minimum-space-to-comment', 'msc', '=i' );
3260 $add_option->( 'non-indenting-braces', 'nib', '!' );
3261 $add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' );
3262 $add_option->( 'outdent-long-comments', 'olc', '!' );
3263 $add_option->( 'outdent-static-block-comments', 'osbc', '!' );
3264 $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' );
3265 $add_option->( 'static-block-comments', 'sbc', '!' );
3266 $add_option->( 'static-side-comment-prefix', 'sscp', '=s' );
3267 $add_option->( 'static-side-comments', 'ssc', '!' );
3268 $add_option->( 'ignore-side-comment-lengths', 'iscl', '!' );
3270 ########################################
3271 $category = 5; # Linebreak controls
3272 ########################################
3273 $add_option->( 'add-newlines', 'anl', '!' );
3274 $add_option->( 'block-brace-vertical-tightness', 'bbvt', '=i' );
3275 $add_option->( 'block-brace-vertical-tightness-list', 'bbvtl', '=s' );
3276 $add_option->( 'brace-follower-vertical-tightness', 'bfvt', '=i' );
3277 $add_option->( 'brace-vertical-tightness', 'bvt', '=i' );
3278 $add_option->( 'brace-vertical-tightness-closing', 'bvtc', '=i' );
3279 $add_option->( 'cuddled-else', 'ce', '!' );
3280 $add_option->( 'cuddled-block-list', 'cbl', '=s' );
3281 $add_option->( 'cuddled-block-list-exclusive', 'cblx', '!' );
3282 $add_option->( 'cuddled-break-option', 'cbo', '=i' );
3283 $add_option->( 'cuddled-paren-brace', 'cpb', '!' );
3284 $add_option->( 'delete-old-newlines', 'dnl', '!' );
3285 $add_option->( 'opening-brace-always-on-right', 'bar', '!' );
3286 $add_option->( 'opening-brace-on-new-line', 'bl', '!' );
3287 $add_option->( 'opening-hash-brace-right', 'ohbr', '!' );
3288 $add_option->( 'opening-paren-right', 'opr', '!' );
3289 $add_option->( 'opening-square-bracket-right', 'osbr', '!' );
3290 $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl', '!' );
3291 $add_option->( 'opening-sub-brace-on-new-line', 'sbl', '!' );
3292 $add_option->( 'paren-vertical-tightness', 'pvt', '=i' );
3293 $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' );
3294 $add_option->( 'weld-nested-containers', 'wn', '!' );
3295 $add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' );
3296 $add_option->( 'weld-fat-comma', 'wfc', '!' );
3297 $add_option->( 'space-backslash-quote', 'sbq', '=i' );
3298 $add_option->( 'stack-closing-block-brace', 'scbb', '!' );
3299 $add_option->( 'stack-closing-hash-brace', 'schb', '!' );
3300 $add_option->( 'stack-closing-paren', 'scp', '!' );
3301 $add_option->( 'stack-closing-square-bracket', 'scsb', '!' );
3302 $add_option->( 'stack-opening-hash-brace', 'sohb', '!' );
3303 $add_option->( 'stack-opening-paren', 'sop', '!' );
3304 $add_option->( 'stack-opening-square-bracket', 'sosb', '!' );
3305 $add_option->( 'vertical-tightness', 'vt', '=i' );
3306 $add_option->( 'vertical-tightness-closing', 'vtc', '=i' );
3307 $add_option->( 'want-break-after', 'wba', '=s' );
3308 $add_option->( 'want-break-before', 'wbb', '=s' );
3309 $add_option->( 'break-after-all-operators', 'baao', '!' );
3310 $add_option->( 'break-before-all-operators', 'bbao', '!' );
3311 $add_option->( 'keep-interior-semicolons', 'kis', '!' );
3312 $add_option->( 'one-line-block-semicolons', 'olbs', '=i' );
3313 $add_option->( 'one-line-block-nesting', 'olbn', '=i' );
3314 $add_option->( 'one-line-block-exclusion-list', 'olbxl', '=s' );
3315 $add_option->( 'break-before-hash-brace', 'bbhb', '=i' );
3316 $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' );
3317 $add_option->( 'break-before-square-bracket', 'bbsb', '=i' );
3318 $add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' );
3319 $add_option->( 'break-before-paren', 'bbp', '=i' );
3320 $add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' );
3321 $add_option->( 'brace-left-list', 'bll', '=s' );
3322 $add_option->( 'brace-left-exclusion-list', 'blxl', '=s' );
3323 $add_option->( 'break-after-labels', 'bal', '=i' );
3325 # This was an experiment mentioned in git #78, originally named -bopl. I
3326 # expanded it to also open logical blocks, based on git discussion #100,
3327 # and renamed it -bocp. It works, but will remain commented out due to
3328 # apparent lack of interest.
3329 # $add_option->( 'break-open-compact-parens', 'bocp', '=s' );
3331 ########################################
3332 $category = 6; # Controlling list formatting
3333 ########################################
3334 $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
3335 $add_option->( 'comma-arrow-breakpoints', 'cab', '=i' );
3336 $add_option->( 'maximum-fields-per-table', 'mft', '=i' );
3338 ########################################
3339 $category = 7; # Retaining or ignoring existing line breaks
3340 ########################################
3341 $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' );
3342 $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' );
3343 $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' );
3344 $add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' );
3345 $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' );
3346 $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
3347 $add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' );
3348 $add_option->( 'keep-old-breakpoints-after', 'kba', '=s' );
3349 $add_option->( 'ignore-old-breakpoints', 'iob', '!' );
3351 ########################################
3352 $category = 8; # Blank line control
3353 ########################################
3354 $add_option->( 'blanks-before-blocks', 'bbb', '!' );
3355 $add_option->( 'blanks-before-comments', 'bbc', '!' );
3356 $add_option->( 'blank-lines-before-subs', 'blbs', '=i' );
3357 $add_option->( 'blank-lines-before-packages', 'blbp', '=i' );
3358 $add_option->( 'long-block-line-count', 'lbl', '=i' );
3359 $add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
3360 $add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
3362 $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
3363 $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
3364 $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
3365 $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
3366 $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
3367 $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
3368 $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
3370 $add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
3371 $add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
3372 $add_option->( 'blank-lines-after-opening-block-list', 'blaol', '=s' );
3373 $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
3375 ########################################
3376 $category = 9; # Other controls
3377 ########################################
3378 $add_option->( 'delete-block-comments', 'dbc', '!' );
3379 $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
3380 $add_option->( 'delete-pod', 'dp', '!' );
3381 $add_option->( 'delete-side-comments', 'dsc', '!' );
3382 $add_option->( 'tee-block-comments', 'tbc', '!' );
3383 $add_option->( 'tee-pod', 'tp', '!' );
3384 $add_option->( 'tee-side-comments', 'tsc', '!' );
3385 $add_option->( 'look-for-autoloader', 'lal', '!' );
3386 $add_option->( 'look-for-hash-bang', 'x', '!' );
3387 $add_option->( 'look-for-selfloader', 'lsl', '!' );
3388 $add_option->( 'pass-version-line', 'pvl', '!' );
3390 ########################################
3391 $category = 13; # Debugging
3392 ########################################
3393 $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE);
3394 $add_option->( 'DEBUG', 'D', '!' );
3395 $add_option->( 'dump-block-summary', 'dbs', '!' );
3396 $add_option->( 'dump-block-minimum-lines', 'dbl', '=i' );
3397 $add_option->( 'dump-block-types', 'dbt', '=s' );
3398 $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' );
3399 $add_option->( 'dump-defaults', 'ddf', '!' );
3400 $add_option->( 'dump-long-names', 'dln', '!' );
3401 $add_option->( 'dump-options', 'dop', '!' );
3402 $add_option->( 'dump-profile', 'dpro', '!' );
3403 $add_option->( 'dump-short-names', 'dsn', '!' );
3404 $add_option->( 'dump-token-types', 'dtt', '!' );
3405 $add_option->( 'dump-want-left-space', 'dwls', '!' );
3406 $add_option->( 'dump-want-right-space', 'dwrs', '!' );
3407 $add_option->( 'fuzzy-line-length', 'fll', '!' );
3408 $add_option->( 'help', 'h', EMPTY_STRING );
3409 $add_option->( 'short-concatenation-item-length', 'scl', '=i' );
3410 $add_option->( 'show-options', 'opt', '!' );
3411 $add_option->( 'timestamp', 'ts', '!' );
3412 $add_option->( 'version', 'v', EMPTY_STRING );
3413 $add_option->( 'memoize', 'mem', '!' );
3414 $add_option->( 'file-size-order', 'fso', '!' );
3415 $add_option->( 'maximum-file-size-mb', 'maxfs', '=i' );
3416 $add_option->( 'maximum-level-errors', 'maxle', '=i' );
3417 $add_option->( 'maximum-unexpected-errors', 'maxue', '=i' );
3419 #---------------------------------------------------------------------
3421 # The Perl::Tidy::HtmlWriter will add its own options to the string
3422 Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
3424 ########################################
3425 # Set categories 10, 11, 12
3426 ########################################
3427 # Based on their known order
3428 $category = 12; # HTML properties
3429 foreach my $opt (@option_string) {
3430 my $long_name = $opt;
3431 $long_name =~ s/(!|=.*|:.*)$//;
3432 unless ( defined( $option_category{$long_name} ) ) {
3433 if ( $long_name =~ /^html-linked/ ) {
3434 $category = 10; # HTML options
3436 elsif ( $long_name =~ /^pod2html/ ) {
3437 $category = 11; # Pod2html
3439 $option_category{$long_name} = $category_name[$category];
3443 #---------------------------------------
3444 # Assign valid ranges to certain options
3445 #---------------------------------------
3446 # In the future, these may be used to make preliminary checks
3447 # hash keys are long names
3448 # If key or value is undefined:
3449 # strings may have any value
3450 # integer ranges are >=0
3451 # If value is defined:
3452 # value is [qw(any valid words)] for strings
3453 # value is [min, max] for integers
3454 # if min is undefined, there is no lower limit
3455 # if max is undefined, there is no upper limit
3456 # Parameters not listed here have defaults
3458 'format' => [ 'tidy', 'html', 'user' ],
3459 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ],
3460 'space-backslash-quote' => [ 0, 2 ],
3461 'block-brace-tightness' => [ 0, 2 ],
3462 'keyword-paren-inner-tightness' => [ 0, 2 ],
3463 'brace-tightness' => [ 0, 2 ],
3464 'paren-tightness' => [ 0, 2 ],
3465 'square-bracket-tightness' => [ 0, 2 ],
3467 'block-brace-vertical-tightness' => [ 0, 2 ],
3468 'brace-follower-vertical-tightness' => [ 0, 2 ],
3469 'brace-vertical-tightness' => [ 0, 2 ],
3470 'brace-vertical-tightness-closing' => [ 0, 2 ],
3471 'paren-vertical-tightness' => [ 0, 2 ],
3472 'paren-vertical-tightness-closing' => [ 0, 2 ],
3473 'square-bracket-vertical-tightness' => [ 0, 2 ],
3474 'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
3475 'vertical-tightness' => [ 0, 2 ],
3476 'vertical-tightness-closing' => [ 0, 2 ],
3478 'closing-brace-indentation' => [ 0, 3 ],
3479 'closing-paren-indentation' => [ 0, 3 ],
3480 'closing-square-bracket-indentation' => [ 0, 3 ],
3481 'closing-token-indentation' => [ 0, 3 ],
3483 'closing-side-comment-else-flag' => [ 0, 2 ],
3484 'comma-arrow-breakpoints' => [ 0, 5 ],
3486 'keyword-group-blanks-before' => [ 0, 2 ],
3487 'keyword-group-blanks-after' => [ 0, 2 ],
3489 'space-prototype-paren' => [ 0, 2 ],
3490 'break-after-labels' => [ 0, 2 ],
3493 # Note: we could actually allow negative ci if someone really wants it:
3494 # $option_range{'continuation-indentation'} = [ undef, undef ];
3496 #------------------------------------------------------------------
3497 # DEFAULTS: Assign default values to the above options here, except
3498 # for 'outfile' and 'help'.
3499 # These settings should approximate the perlstyle(1) suggestions.
3500 #------------------------------------------------------------------
3503 add-terminal-newline
3506 blanks-before-blocks
3507 blanks-before-comments
3508 blank-lines-before-subs=1
3509 blank-lines-before-packages=1
3511 keyword-group-blanks-size=5
3512 keyword-group-blanks-repeat-count=0
3513 keyword-group-blanks-before=1
3514 keyword-group-blanks-after=1
3515 nokeyword-group-blanks-inside
3516 nokeyword-group-blanks-delete
3518 block-brace-tightness=0
3519 block-brace-vertical-tightness=0
3520 brace-follower-vertical-tightness=1
3522 brace-vertical-tightness-closing=0
3523 brace-vertical-tightness=0
3524 break-after-labels=0
3525 break-at-old-logical-breakpoints
3526 break-at-old-ternary-breakpoints
3527 break-at-old-attribute-breakpoints
3528 break-at-old-keyword-breakpoints
3529 break-before-hash-brace=0
3530 break-before-hash-brace-and-indent=0
3531 break-before-square-bracket=0
3532 break-before-square-bracket-and-indent=0
3533 break-before-paren=0
3534 break-before-paren-and-indent=0
3535 comma-arrow-breakpoints=5
3537 character-encoding=guess
3538 closing-side-comment-interval=6
3539 closing-side-comment-maximum-text=20
3540 closing-side-comment-else-flag=0
3541 closing-side-comments-balanced
3542 closing-paren-indentation=0
3543 closing-brace-indentation=0
3544 closing-square-bracket-indentation=0
3545 continuation-indentation=2
3546 noextended-continuation-indentation
3547 cuddled-break-option=1
3550 dump-block-minimum-lines=20
3551 dump-block-types=sub
3553 encode-output-strings
3554 function-paren-vertical-alignment
3556 hanging-side-comments
3557 indent-block-comments
3560 keep-old-blank-lines=1
3561 keyword-paren-inner-tightness=1
3563 long-block-line-count=8
3566 maximum-consecutive-blank-lines=1
3567 maximum-fields-per-table=0
3568 maximum-line-length=80
3569 maximum-file-size-mb=10
3570 maximum-level-errors=1
3571 maximum-unexpected-errors=0
3573 minimum-space-to-comment=4
3574 nobrace-left-and-indent
3576 nodelete-old-whitespace
3579 non-indenting-braces
3582 nostatic-side-comments
3585 one-line-block-semicolons=1
3586 one-line-block-nesting=0
3589 outdent-long-comments
3591 paren-vertical-tightness-closing=0
3592 paren-vertical-tightness=0
3594 noweld-nested-containers
3596 nouse-unicode-gcstring
3599 valign-block-comments
3600 valign-side-comments
3601 short-concatenation-item-length=8
3603 space-backslash-quote=1
3604 space-prototype-paren=1
3605 square-bracket-tightness=1
3606 square-bracket-vertical-tightness-closing=0
3607 square-bracket-vertical-tightness=0
3608 static-block-comments
3613 backup-file-extension=bak
3619 html-table-of-contents
3623 #-----------------------------------------------------------------------
3624 # Define abbreviations which will be expanded into the above primitives.
3625 # These may be defined recursively.
3626 #-----------------------------------------------------------------------
3629 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)],
3630 'fnl' => [qw(freeze-newlines)],
3631 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
3632 'fws' => [qw(freeze-whitespace)],
3633 'freeze-blank-lines' =>
3634 [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
3635 'fbl' => [qw(freeze-blank-lines)],
3636 'indent-only' => [qw(freeze-newlines freeze-whitespace)],
3637 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
3638 'nooutdent-long-lines' =>
3639 [qw(nooutdent-long-quotes nooutdent-long-comments)],
3640 'oll' => [qw(outdent-long-lines)],
3641 'noll' => [qw(nooutdent-long-lines)],
3642 'io' => [qw(indent-only)],
3643 'delete-all-comments' =>
3644 [qw(delete-block-comments delete-side-comments delete-pod)],
3645 'nodelete-all-comments' =>
3646 [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
3647 'dac' => [qw(delete-all-comments)],
3648 'ndac' => [qw(nodelete-all-comments)],
3649 'gnu' => [qw(gnu-style)],
3650 'pbp' => [qw(perl-best-practices)],
3651 'tee-all-comments' =>
3652 [qw(tee-block-comments tee-side-comments tee-pod)],
3653 'notee-all-comments' =>
3654 [qw(notee-block-comments notee-side-comments notee-pod)],
3655 'tac' => [qw(tee-all-comments)],
3656 'ntac' => [qw(notee-all-comments)],
3657 'html' => [qw(format=html)],
3658 'nhtml' => [qw(format=tidy)],
3659 'tidy' => [qw(format=tidy)],
3661 'brace-left' => [qw(opening-brace-on-new-line)],
3663 # -cb is now a synonym for -ce
3664 'cb' => [qw(cuddled-else)],
3665 'cuddled-blocks' => [qw(cuddled-else)],
3667 'utf8' => [qw(character-encoding=utf8)],
3668 'UTF8' => [qw(character-encoding=utf8)],
3669 'guess' => [qw(character-encoding=guess)],
3671 'swallow-optional-blank-lines' => [qw(kbl=0)],
3672 'noswallow-optional-blank-lines' => [qw(kbl=1)],
3673 'sob' => [qw(kbl=0)],
3674 'nsob' => [qw(kbl=1)],
3676 'break-after-comma-arrows' => [qw(cab=0)],
3677 'nobreak-after-comma-arrows' => [qw(cab=1)],
3678 'baa' => [qw(cab=0)],
3679 'nbaa' => [qw(cab=1)],
3681 'blanks-before-subs' => [qw(blbs=1 blbp=1)],
3682 'bbs' => [qw(blbs=1 blbp=1)],
3683 'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
3684 'nbbs' => [qw(blbs=0 blbp=0)],
3686 'keyword-group-blanks' => [qw(kgbb=2 kgbi kgba=2)],
3687 'kgb' => [qw(kgbb=2 kgbi kgba=2)],
3688 'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
3689 'nkgb' => [qw(kgbb=1 nkgbi kgba=1)],
3691 'break-at-old-trinary-breakpoints' => [qw(bot)],
3693 'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
3694 'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
3695 'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
3696 'icp' => [qw(cpi=2 cbi=2 csbi=2)],
3697 'nicp' => [qw(cpi=0 cbi=0 csbi=0)],
3699 'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
3700 'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
3701 'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
3702 'indent-closing-paren' => [qw(cpi=2 cbi=2 csbi=2)],
3703 'noindent-closing-paren' => [qw(cpi=0 cbi=0 csbi=0)],
3705 'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3706 'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3707 'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3709 'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
3710 'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
3711 'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
3713 'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3714 'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3715 'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3717 'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
3718 'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
3719 'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
3721 'otr' => [qw(opr ohbr osbr)],
3722 'opening-token-right' => [qw(opr ohbr osbr)],
3723 'notr' => [qw(nopr nohbr nosbr)],
3724 'noopening-token-right' => [qw(nopr nohbr nosbr)],
3726 'sot' => [qw(sop sohb sosb)],
3727 'nsot' => [qw(nsop nsohb nsosb)],
3728 'stack-opening-tokens' => [qw(sop sohb sosb)],
3729 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
3731 'sct' => [qw(scp schb scsb)],
3732 'stack-closing-tokens' => [qw(scp schb scsb)],
3733 'nsct' => [qw(nscp nschb nscsb)],
3734 'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
3736 'sac' => [qw(sot sct)],
3737 'nsac' => [qw(nsot nsct)],
3738 'stack-all-containers' => [qw(sot sct)],
3739 'nostack-all-containers' => [qw(nsot nsct)],
3741 'act=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3742 'act=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3743 'act=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3744 'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
3745 'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
3746 'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
3748 'stack-opening-block-brace' => [qw(bbvt=2 bbvtl=*)],
3749 'sobb' => [qw(bbvt=2 bbvtl=*)],
3750 'nostack-opening-block-brace' => [qw(bbvt=0)],
3751 'nsobb' => [qw(bbvt=0)],
3753 'converge' => [qw(it=4)],
3754 'noconverge' => [qw(it=1)],
3755 'conv' => [qw(it=4)],
3756 'nconv' => [qw(it=1)],
3758 'valign' => [qw(vc vsc vbc)],
3759 'novalign' => [qw(nvc nvsc nvbc)],
3761 # NOTE: This is a possible future shortcut. But it will remain
3762 # deactivated until the -lpxl flag is no longer experimental.
3763 # 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ],
3764 # 'lfp' => [qw(line-up-function-parentheses)],
3766 # 'mangle' originally deleted pod and comments, but to keep it
3767 # reversible, it no longer does. But if you really want to
3768 # delete them, just use:
3771 # An interesting use for 'mangle' is to do this:
3772 # perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
3773 # which will form as many one-line blocks as possible
3777 keep-old-blank-lines=0
3779 delete-old-whitespace
3782 maximum-consecutive-blank-lines=0
3783 maximum-line-length=100000
3787 noblanks-before-blocks
3788 blank-lines-before-subs=0
3789 blank-lines-before-packages=0
3794 # 'extrude' originally deleted pod and comments, but to keep it
3795 # reversible, it no longer does. But if you really want to
3796 # delete them, just use
3799 # An interesting use for 'extrude' is to do this:
3800 # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
3801 # which will break up all one-line blocks.
3806 delete-old-whitespace
3809 maximum-consecutive-blank-lines=0
3810 maximum-line-length=1
3813 noblanks-before-blocks
3814 blank-lines-before-subs=0
3815 blank-lines-before-packages=0
3822 # this style tries to follow the GNU Coding Standards (which do
3823 # not really apply to perl but which are followed by some perl
3827 lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
3831 # Style suggested in Damian Conway's Perl Best Practices
3832 'perl-best-practices' => [
3833 qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
3834 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
3837 # Additional styles can be added here
3840 Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
3842 # Uncomment next line to dump all expansions for debugging:
3843 # dump_short_names(\%expansion);
3845 \@option_string, \@defaults, \%expansion,
3846 \%option_category, \%option_range
3849 } ## end sub generate_options
3851 # Memoize process_command_line. Given same @ARGV passed in, return same
3852 # values and same @ARGV back.
3853 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
3854 # up masontidy (https://metacpan.org/module/masontidy)
3856 my %process_command_line_cache;
3858 sub process_command_line {
3862 $perltidyrc_stream, $is_Windows, $Windows_type,
3863 $rpending_complaint, $dump_options_type
3866 my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
3868 my $cache_key = join( chr(28), @ARGV );
3869 if ( my $result = $process_command_line_cache{$cache_key} ) {
3870 my ( $argv, @retvals ) = @{$result};
3875 my @retvals = _process_command_line(@q);
3876 $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
3877 if $retvals[0]->{'memoize'};
3882 return _process_command_line(@q);
3884 } ## end sub process_command_line
3886 # (note the underscore here)
3887 sub _process_command_line {
3890 $perltidyrc_stream, $is_Windows, $Windows_type,
3891 $rpending_complaint, $dump_options_type
3896 # Save any current Getopt::Long configuration
3897 # and set to Getopt::Long defaults. Use eval to avoid
3898 # breaking old versions of Perl without these routines.
3899 # Previous configuration is reset at the exit of this routine.
3901 if ( eval { $glc = Getopt::Long::Configure(); 1 } ) {
3902 my $ok = eval { Getopt::Long::ConfigDefaults(); 1 };
3903 if ( !$ok && DEVEL_MODE ) {
3904 Fault("Failed call to Getopt::Long::ConfigDefaults: $EVAL_ERROR\n");
3907 else { $glc = undef }
3910 $roption_string, $rdefaults, $rexpansion,
3911 $roption_category, $roption_range
3912 ) = generate_options();
3914 #--------------------------------------------------------------
3915 # set the defaults by passing the above list through GetOptions
3916 #--------------------------------------------------------------
3921 # do not load the defaults if we are just dumping perltidyrc
3922 unless ( $dump_options_type eq 'perltidyrc' ) {
3923 for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
3925 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
3927 "Programming Bug reported by 'GetOptions': error in setting default options"
3932 my @raw_options = ();
3933 my $config_file = EMPTY_STRING;
3934 my $saw_ignore_profile = 0;
3935 my $saw_dump_profile = 0;
3937 #--------------------------------------------------------------
3938 # Take a first look at the command-line parameters. Do as many
3939 # immediate dumps as possible, which can avoid confusion if the
3940 # perltidyrc file has an error.
3941 #--------------------------------------------------------------
3942 foreach my $i (@ARGV) {
3945 if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
3946 $saw_ignore_profile = 1;
3949 # note: this must come before -pro and -profile, below:
3950 elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
3951 $saw_dump_profile = 1;
3953 elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
3956 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
3961 # resolve <dir>/.../<file>, meaning look upwards from directory
3962 if ( defined($config_file) ) {
3963 if ( my ( $start_dir, $search_file ) =
3964 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
3966 $start_dir = '.' if !$start_dir;
3967 $start_dir = Cwd::realpath($start_dir);
3968 if ( my $found_file =
3969 find_file_upwards( $start_dir, $search_file ) )
3971 $config_file = $found_file;
3975 unless ( -e $config_file ) {
3976 Warn("cannot find file given with -pro=$config_file: $ERRNO\n");
3977 $config_file = EMPTY_STRING;
3980 elsif ( $i =~ /^-(pro|profile)=?$/ ) {
3981 Die("usage: -pro=filename or --profile=filename, no spaces\n");
3983 elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
3987 elsif ( $i =~ /^-(version|v)$/ ) {
3991 elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
3992 dump_defaults( @{$rdefaults} );
3995 elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
3996 dump_long_names( @{$roption_string} );
3999 elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
4000 dump_short_names($rexpansion);
4003 elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
4004 Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
4009 if ( $saw_dump_profile && $saw_ignore_profile ) {
4010 Warn("No profile to dump because of -npro\n");
4014 #----------------------------------------
4015 # read any .perltidyrc configuration file
4016 #----------------------------------------
4017 unless ($saw_ignore_profile) {
4019 # resolve possible conflict between $perltidyrc_stream passed
4020 # as call parameter to perltidy and -pro=filename on command
4022 if ($perltidyrc_stream) {
4025 Conflict: a perltidyrc configuration file was specified both as this
4026 perltidy call parameter: $perltidyrc_stream
4027 and with this -profile=$config_file.
4028 Using -profile=$config_file.
4032 $config_file = $perltidyrc_stream;
4036 # look for a config file if we don't have one yet
4037 my $rconfig_file_chatter;
4038 ${$rconfig_file_chatter} = EMPTY_STRING;
4040 find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
4041 $rpending_complaint )
4042 unless $config_file;
4044 # open any config file
4047 ( $fh_config, $config_file ) =
4048 Perl::Tidy::streamhandle( $config_file, 'r' );
4049 unless ($fh_config) {
4050 ${$rconfig_file_chatter} .=
4051 "# $config_file exists but cannot be opened\n";
4055 if ($saw_dump_profile) {
4056 dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
4062 my ( $rconfig_list, $death_message ) =
4063 read_config_file( $fh_config, $config_file, $rexpansion );
4064 Die($death_message) if ($death_message);
4066 # process any .perltidyrc parameters right now so we can
4068 if ( @{$rconfig_list} ) {
4069 local @ARGV = @{$rconfig_list};
4071 expand_command_abbreviations( $rexpansion, \@raw_options,
4074 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
4076 "Error in this config file: $config_file \nUse -npro to ignore this file, -h for help'\n"
4080 # Anything left in this local @ARGV is an error and must be
4081 # invalid bare words from the configuration file. We cannot
4082 # check this earlier because bare words may have been valid
4083 # values for parameters. We had to wait for GetOptions to have
4087 my $str = "\'" . pop(@ARGV) . "\'";
4088 while ( my $param = pop(@ARGV) ) {
4089 if ( length($str) < 70 ) {
4090 $str .= ", '$param'";
4098 There are $count unrecognized values in the configuration file '$config_file':
4100 Use leading dashes for parameters. Use -npro to ignore this file.
4104 # Undo any options which cause premature exit. They are not
4105 # appropriate for a config file, and it could be hard to
4106 # diagnose the cause of the premature exit.
4109 dump-cuddled-block-list
4116 dump-want-left-space
4117 dump-want-right-space
4126 if ( defined( $Opts{$_} ) ) {
4128 Warn("ignoring --$_ in config file: $config_file\n");
4135 #----------------------------------------
4136 # now process the command line parameters
4137 #----------------------------------------
4138 expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
4140 local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
4141 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
4142 Die("Error on command line; for help try 'perltidy -h'\n");
4145 # reset Getopt::Long configuration back to its previous value
4146 if ( defined($glc) ) {
4147 my $ok = eval { Getopt::Long::Configure($glc); 1 };
4148 if ( !$ok && DEVEL_MODE ) {
4149 Fault("Could not reset Getopt::Long configuration: $EVAL_ERROR\n");
4153 return ( \%Opts, $config_file, \@raw_options, $roption_string,
4154 $rexpansion, $roption_category, $roption_range );
4155 } ## end sub _process_command_line
4157 sub make_grep_alias_string {
4160 # Defaults: list operators in List::Util
4161 # Possible future additions: pairfirst pairgrep pairmap
4162 my $default_string = join SPACE, qw(
4172 # make a hash of any excluded words
4173 my %is_excluded_word;
4174 my $exclude_string = $rOpts->{'grep-alias-exclusion-list'};
4175 if ($exclude_string) {
4176 $exclude_string =~ s/,/ /g; # allow commas
4177 $exclude_string =~ s/^\s+//;
4178 $exclude_string =~ s/\s+$//;
4179 my @q = split /\s+/, $exclude_string;
4180 @is_excluded_word{@q} = (1) x scalar(@q);
4183 # The special option -gaxl='*' removes all defaults
4184 if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING }
4186 # combine the defaults and any input list
4187 my $input_string = $rOpts->{'grep-alias-list'};
4188 if ($input_string) { $input_string .= SPACE . $default_string }
4189 else { $input_string = $default_string }
4191 # Now make the final list of unique grep alias words
4192 $input_string =~ s/,/ /g; # allow commas
4193 $input_string =~ s/^\s+//;
4194 $input_string =~ s/\s+$//;
4195 my @word_list = split /\s+/, $input_string;
4196 my @filtered_word_list;
4199 foreach my $word (@word_list) {
4201 if ( $word !~ /^\w[\w\d]*$/ ) {
4203 "unexpected word in --grep-alias-list: '$word' - ignoring\n"
4206 if ( !$seen{$word} && !$is_excluded_word{$word} ) {
4208 push @filtered_word_list, $word;
4212 my $joined_words = join SPACE, @filtered_word_list;
4213 $rOpts->{'grep-alias-list'} = $joined_words;
4215 } ## end sub make_grep_alias_string
4217 sub cleanup_word_list {
4218 my ( $rOpts, $option_name, $rforced_words ) = @_;
4220 # Clean up the list of words in a user option to simplify use by
4221 # later routines (delete repeats, replace commas with single space,
4225 # $rOpts - the global option hash
4226 # $option_name - hash key of this option
4227 # $rforced_words - ref to list of any words to be added
4230 # \%seen - hash of the final list of words
4235 my $input_string = $rOpts->{$option_name};
4236 if ( defined($input_string) && length($input_string) ) {
4237 $input_string =~ s/,/ /g; # allow commas
4238 $input_string =~ s/^\s+//;
4239 $input_string =~ s/\s+$//;
4240 @input_list = split /\s+/, $input_string;
4243 if ($rforced_words) {
4244 push @input_list, @{$rforced_words};
4247 my @filtered_word_list;
4248 foreach my $word (@input_list) {
4251 # look for obviously bad words
4252 if ( $word =~ /^\d/ || $word !~ /^\w[\w\d]*$/ ) {
4253 Warn("unexpected '$option_name' word '$word' - ignoring\n");
4255 if ( !$seen{$word} ) {
4257 push @filtered_word_list, $word;
4261 $rOpts->{$option_name} = join SPACE, @filtered_word_list;
4263 } ## end sub cleanup_word_list
4267 my ( $self, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
4269 my $rOpts = $self->[_rOpts_];
4271 #------------------------------------------------------------
4272 # check and handle any interactions among the basic options..
4273 #------------------------------------------------------------
4275 # Since perltidy only encodes in utf8, problems can occur if we let it
4276 # decode anything else. See discussions for issue git #83.
4277 my $encoding = $rOpts->{'character-encoding'};
4278 if ( $encoding !~ /^\s*(guess|none|utf8|utf-8)\s*$/i ) {
4280 --character-encoding = '$encoding' is not allowed; the options are: 'none', 'guess', 'utf8'
4284 # Since -vt, -vtc, and -cti are abbreviations, but under
4285 # msdos, an unquoted input parameter like vtc=1 will be
4286 # seen as 2 parameters, vtc and 1, so the abbreviations
4287 # won't be seen. Therefore, we will catch them here if
4290 if ( defined $rOpts->{'vertical-tightness'} ) {
4291 my $vt = $rOpts->{'vertical-tightness'};
4292 $rOpts->{'paren-vertical-tightness'} = $vt;
4293 $rOpts->{'square-bracket-vertical-tightness'} = $vt;
4294 $rOpts->{'brace-vertical-tightness'} = $vt;
4297 if ( defined $rOpts->{'vertical-tightness-closing'} ) {
4298 my $vtc = $rOpts->{'vertical-tightness-closing'};
4299 $rOpts->{'paren-vertical-tightness-closing'} = $vtc;
4300 $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
4301 $rOpts->{'brace-vertical-tightness-closing'} = $vtc;
4304 if ( defined $rOpts->{'closing-token-indentation'} ) {
4305 my $cti = $rOpts->{'closing-token-indentation'};
4306 $rOpts->{'closing-square-bracket-indentation'} = $cti;
4307 $rOpts->{'closing-brace-indentation'} = $cti;
4308 $rOpts->{'closing-paren-indentation'} = $cti;
4311 # Syntax checking is no longer supported due to concerns about executing
4312 # code in BEGIN blocks. The flag is still accepted for backwards
4313 # compatibility but is ignored if set.
4314 $rOpts->{'check-syntax'} = 0;
4316 my $check_blank_count = sub {
4317 my ( $key, $abbrev ) = @_;
4318 if ( $rOpts->{$key} ) {
4319 if ( $rOpts->{$key} < 0 ) {
4321 Warn("negative value of $abbrev, setting 0\n");
4323 if ( $rOpts->{$key} > 100 ) {
4324 Warn("unreasonably large value of $abbrev, reducing\n");
4325 $rOpts->{$key} = 100;
4331 # check for reasonable number of blank lines and fix to avoid problems
4332 $check_blank_count->( 'blank-lines-before-subs', '-blbs' );
4333 $check_blank_count->( 'blank-lines-before-packages', '-blbp' );
4334 $check_blank_count->( 'blank-lines-after-block-opening', '-blao' );
4335 $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
4337 # setting a non-negative logfile gap causes logfile to be saved
4338 if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
4339 $rOpts->{'logfile'} = 1;
4342 # set short-cut flag when only indentation is to be done.
4343 # Note that the user may or may not have already set the
4345 if ( !$rOpts->{'add-whitespace'}
4346 && !$rOpts->{'delete-old-whitespace'}
4347 && !$rOpts->{'add-newlines'}
4348 && !$rOpts->{'delete-old-newlines'} )
4350 $rOpts->{'indent-only'} = 1;
4353 # -isbc implies -ibc
4354 if ( $rOpts->{'indent-spaced-block-comments'} ) {
4355 $rOpts->{'indent-block-comments'} = 1;
4358 # -bar cannot be used with -bl or -bli; arbitrarily keep -bar
4359 if ( $rOpts->{'opening-brace-always-on-right'} ) {
4361 if ( $rOpts->{'opening-brace-on-new-line'} ) {
4363 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
4364 'opening-brace-on-new-line' (-bl). Ignoring -bl.
4366 $rOpts->{'opening-brace-on-new-line'} = 0;
4368 if ( $rOpts->{'brace-left-and-indent'} ) {
4370 Conflict: you specified both 'opening-brace-always-on-right' (-bar) and
4371 '--brace-left-and-indent' (-bli). Ignoring -bli.
4373 $rOpts->{'brace-left-and-indent'} = 0;
4377 # it simplifies things if -bl is 0 rather than undefined
4378 if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
4379 $rOpts->{'opening-brace-on-new-line'} = 0;
4382 if ( $rOpts->{'entab-leading-whitespace'} ) {
4383 if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
4384 Warn("-et=n must use a positive integer; ignoring -et\n");
4385 $rOpts->{'entab-leading-whitespace'} = undef;
4388 # entab leading whitespace has priority over the older 'tabs' option
4389 if ( $rOpts->{'tabs'} ) {
4391 # The following warning could be added but would annoy a lot of
4392 # users who have a perltidyrc with both -t and -et=n. So instead
4393 # there is a note in the manual that -et overrides -t.
4394 ##Warn("-tabs and -et=n conflict; ignoring -tabs\n");
4395 $rOpts->{'tabs'} = 0;
4399 # set a default tabsize to be used in guessing the starting indentation
4400 # level if and only if this run does not use tabs and the old code does
4402 if ( $rOpts->{'default-tabsize'} ) {
4403 if ( $rOpts->{'default-tabsize'} < 0 ) {
4404 Warn("negative value of -dt, setting 0\n");
4405 $rOpts->{'default-tabsize'} = 0;
4407 if ( $rOpts->{'default-tabsize'} > 20 ) {
4408 Warn("unreasonably large value of -dt, reducing\n");
4409 $rOpts->{'default-tabsize'} = 20;
4413 $rOpts->{'default-tabsize'} = 8;
4416 # Check and clean up any use-feature list
4417 my $saw_use_feature_class;
4418 if ( $rOpts->{'use-feature'} ) {
4419 my $rseen = cleanup_word_list( $rOpts, 'use-feature' );
4420 $saw_use_feature_class = $rseen->{'class'};
4423 # Check and clean up any sub-alias-list
4425 defined( $rOpts->{'sub-alias-list'} )
4426 && length( $rOpts->{'sub-alias-list'} )
4428 || $saw_use_feature_class
4433 # include 'sub' for convenience if this option is used
4434 push @forced_words, 'sub';
4436 # use-feature=class requires method as a sub alias
4437 push @forced_words, 'method' if ($saw_use_feature_class);
4439 cleanup_word_list( $rOpts, 'sub-alias-list', \@forced_words );
4442 make_grep_alias_string($rOpts);
4444 # Turn on fuzzy-line-length unless this is an extrude run, as determined
4445 # by the -i and -ci settings. Otherwise blinkers can form (case b935)
4446 if ( !$rOpts->{'fuzzy-line-length'} ) {
4447 if ( $rOpts->{'maximum-line-length'} != 1
4448 || $rOpts->{'continuation-indentation'} != 0 )
4450 $rOpts->{'fuzzy-line-length'} = 1;
4454 # Large values of -scl can cause convergence problems, issue c167
4455 if ( $rOpts->{'short-concatenation-item-length'} > 12 ) {
4456 $rOpts->{'short-concatenation-item-length'} = 12;
4459 # The freeze-whitespace option is currently a derived option which has its
4461 $rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'}
4462 && !$rOpts->{'delete-old-whitespace'};
4464 # Turn off certain options if whitespace is frozen
4465 # Note: vertical alignment will be automatically shut off
4466 if ( $rOpts->{'freeze-whitespace'} ) {
4467 $rOpts->{'logical-padding'} = 0;
4470 # Define $tabsize, the number of spaces per tab for use in
4471 # guessing the indentation of source lines with leading tabs.
4472 # Assume same as for this run if tabs are used, otherwise assume
4473 # a default value, typically 8
4474 $self->[_tabsize_] =
4475 $rOpts->{'entab-leading-whitespace'}
4476 ? $rOpts->{'entab-leading-whitespace'}
4477 : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
4478 : $rOpts->{'default-tabsize'};
4480 # Define the default line ending, before any -ple option is applied
4481 $self->[_line_separator_default_] = get_line_separator_default($rOpts);
4484 } ## end sub check_options
4486 sub get_line_separator_default {
4488 my ( $rOpts, $input_file ) = @_;
4490 # Get the line separator that will apply unless overriden by a
4491 # --preserve-line-endings flag for a specific file
4493 my $line_separator_default = "\n";
4495 my $ole = $rOpts->{'output-line-ending'};
4504 $line_separator_default = $endings{ lc $ole };
4506 if ( !$line_separator_default ) {
4507 my $str = join SPACE, keys %endings;
4509 Unrecognized line ending '$ole'; expecting one of: $str
4513 # Check for conflict with -ple
4514 if ( $rOpts->{'preserve-line-endings'} ) {
4515 Warn("Ignoring -ple; conflicts with -ole\n");
4516 $rOpts->{'preserve-line-endings'} = undef;
4520 return $line_separator_default;
4522 } ## end sub get_line_separator_default
4524 sub find_file_upwards {
4525 my ( $search_dir, $search_file ) = @_;
4527 $search_dir =~ s{/+$}{};
4528 $search_file =~ s{^/+}{};
4531 my $try_path = "$search_dir/$search_file";
4532 if ( -f $try_path ) {
4535 elsif ( $search_dir eq '/' ) {
4539 $search_dir = dirname($search_dir);
4543 # This return is for Perl-Critic.
4544 # We shouldn't get out of the while loop without a return
4546 } ## end sub find_file_upwards
4548 sub expand_command_abbreviations {
4550 # go through @ARGV and expand any abbreviations
4552 my ( $rexpansion, $rraw_options, $config_file ) = @_;
4554 # set a pass limit to prevent an infinite loop;
4555 # 10 should be plenty, but it may be increased to allow deeply
4556 # nested expansions.
4557 my $max_passes = 10;
4559 # keep looping until all expansions have been converted into actual
4561 foreach my $pass_count ( 0 .. $max_passes ) {
4563 my $abbrev_count = 0;
4565 # loop over each item in @ARGV..
4566 foreach my $word (@ARGV) {
4568 # convert any leading 'no-' to just 'no'
4569 if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
4571 # if it is a dash flag (instead of a file name)..
4572 if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
4577 # save the raw input for debug output in case of circular refs
4578 if ( $pass_count == 0 ) {
4579 push( @{$rraw_options}, $word );
4582 # recombine abbreviation and flag, if necessary,
4583 # to allow abbreviations with arguments such as '-vt=1'
4584 if ( $rexpansion->{ $abr . $flags } ) {
4585 $abr = $abr . $flags;
4586 $flags = EMPTY_STRING;
4589 # if we see this dash item in the expansion hash..
4590 if ( $rexpansion->{$abr} ) {
4593 # stuff all of the words that it expands to into the
4594 # new arg list for the next pass
4595 foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
4596 next unless $abbrev; # for safety; shouldn't happen
4597 push( @new_argv, '--' . $abbrev . $flags );
4601 # not in expansion hash, must be actual long name
4603 push( @new_argv, $word );
4607 # not a dash item, so just save it for the next pass
4609 push( @new_argv, $word );
4611 } ## end of this pass
4613 # update parameter list @ARGV to the new one
4615 last if ( !$abbrev_count );
4617 # make sure we are not in an infinite loop
4618 if ( $pass_count == $max_passes ) {
4619 local $LIST_SEPARATOR = ')(';
4621 I'm tired. We seem to be in an infinite loop trying to expand aliases.
4622 Here are the raw options;
4625 my $num = @new_argv;
4628 After $max_passes passes here is ARGV
4634 After $max_passes passes ARGV has $num entries
4640 Please check your configuration file $config_file for circular-references.
4641 To deactivate it, use -npro.
4646 Program bug - circular-references in the %expansion hash, probably due to
4647 a recent program change.
4650 } ## end of check for circular references
4651 } ## end of loop over all passes
4653 } ## end sub expand_command_abbreviations
4655 # Debug routine -- this will dump the expansion hash
4656 sub dump_short_names {
4657 my $rexpansion = shift;
4659 List of short names. This list shows how all abbreviations are
4660 translated into other abbreviations and, eventually, into long names.
4661 New abbreviations may be defined in a .perltidyrc file.
4662 For a list of all long names, use perltidy --dump-long-names (-dln).
4663 --------------------------------------------------------------------------
4665 foreach my $abbrev ( sort keys %{$rexpansion} ) {
4666 my @list = @{ $rexpansion->{$abbrev} };
4667 print STDOUT "$abbrev --> @list\n";
4670 } ## end sub dump_short_names
4672 sub check_vms_filename {
4674 # given a valid filename (the perltidy input file)
4675 # create a modified filename and separator character
4678 # Contributed by Michael Cartmell
4680 my $filename = shift;
4681 my ( $base, $path ) = fileparse($filename);
4683 # remove explicit ; version
4684 $base =~ s/;-?\d*$//
4686 # remove explicit . version ie two dots in filename NB ^ escapes a dot
4687 or $base =~ s/( # begin capture $1
4688 (?:^|[^^])\. # match a dot not preceded by a caret
4689 (?: # followed by nothing
4691 .*[^^] # anything ending in a non caret
4694 \.-?\d*$ # match . version number
4697 # normalize filename, if there are no unescaped dots then append one
4698 $base .= '.' unless $base =~ /(?:^|[^^])\./;
4700 # if we don't already have an extension then we just append the extension
4701 my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_";
4702 return ( $path . $base, $separator );
4703 } ## end sub check_vms_filename
4707 # TODO: are these more standard names?
4708 # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
4710 # Returns a string that determines what MS OS we are on.
4711 # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
4712 # Returns blank string if not an MS system.
4713 # Original code contributed by: Yves Orton
4714 # We need to know this to decide where to look for config files
4716 my $rpending_complaint = shift;
4717 my $os = EMPTY_STRING;
4718 return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box?
4720 # Systems built from Perl source may not have Win32.pm
4721 # But probably have Win32::GetOSVersion() anyway so the
4722 # following line is not 'required':
4723 # return $os unless eval('require Win32');
4725 # Use the standard API call to determine the version
4726 my ( $undef, $major, $minor, $build, $id );
4728 ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion();
4731 if ( !$ok && DEVEL_MODE ) {
4732 Fault("Could not cal Win32::GetOSVersion(): $EVAL_ERROR\n");
4736 # NAME ID MAJOR MINOR
4737 # Windows NT 4 2 4 0
4738 # Windows 2000 2 5 0
4740 # Windows Server 2003 2 5 2
4742 return "win32s" unless $id; # If id==0 then its a win32s box.
4743 $os = { # Magic numbers from MSDN
4744 # documentation of GetOSVersion
4751 0 => "2000", # or NT 4, see below
4758 # If $os is undefined, the above code is out of date. Suggested updates
4760 unless ( defined $os ) {
4763 # Deactivated this message 20180322 because it was needlessly
4764 # causing some test scripts to fail. Need help from someone
4765 # with expertise in Windows to decide what is possible with windows.
4766 ${$rpending_complaint} .= <<EOS if (0);
4767 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
4768 We won't be able to look for a system-wide config file.
4772 # Unfortunately the logic used for the various versions isn't so clever..
4773 # so we have to handle an outside case.
4774 return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
4775 } ## end sub Win_OS_Type
4777 sub look_for_Windows {
4779 # determine Windows sub-type and location of
4780 # system-wide configuration files
4781 my $rpending_complaint = shift;
4782 my $is_Windows = ( $OSNAME =~ /win32|dos/i );
4784 $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
4785 return ( $is_Windows, $Windows_type );
4786 } ## end sub look_for_Windows
4788 sub find_config_file {
4790 # look for a .perltidyrc configuration file
4791 # For Windows also look for a file named perltidy.ini
4792 my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
4793 $rpending_complaint )
4796 ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
4798 ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
4801 ${$rconfig_file_chatter} .= " $OSNAME\n";
4804 # sub to check file existence and record all tests
4805 my $exists_config_file = sub {
4806 my $config_file = shift;
4807 return 0 unless $config_file;
4808 ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
4809 return -f $config_file;
4812 # Sub to search upward for config file
4813 my $resolve_config_file = sub {
4815 # resolve <dir>/.../<file>, meaning look upwards from directory
4816 my $config_file = shift;
4818 if ( my ( $start_dir, $search_file ) =
4819 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
4821 ${$rconfig_file_chatter} .=
4822 "# Searching Upward: $config_file\n";
4823 $start_dir = '.' if !$start_dir;
4824 $start_dir = Cwd::realpath($start_dir);
4825 if ( my $found_file =
4826 find_file_upwards( $start_dir, $search_file ) )
4828 $config_file = $found_file;
4829 ${$rconfig_file_chatter} .= "# Found: $config_file\n";
4833 return $config_file;
4838 # look in current directory first
4839 $config_file = ".perltidyrc";
4840 return $config_file if $exists_config_file->($config_file);
4842 $config_file = "perltidy.ini";
4843 return $config_file if $exists_config_file->($config_file);
4846 # Default environment vars.
4847 my @envs = qw(PERLTIDY HOME);
4849 # Check the NT/2k/XP locations, first a local machine def, then a
4851 push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i;
4853 # Now go through the environment ...
4854 foreach my $var (@envs) {
4855 ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
4856 if ( defined( $ENV{$var} ) ) {
4857 ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
4859 # test ENV{ PERLTIDY } as file:
4860 if ( $var eq 'PERLTIDY' ) {
4861 $config_file = "$ENV{$var}";
4862 $config_file = $resolve_config_file->($config_file);
4863 return $config_file if $exists_config_file->($config_file);
4866 # test ENV as directory:
4867 $config_file = catfile( $ENV{$var}, ".perltidyrc" );
4868 $config_file = $resolve_config_file->($config_file);
4869 return $config_file if $exists_config_file->($config_file);
4872 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
4873 $config_file = $resolve_config_file->($config_file);
4874 return $config_file if $exists_config_file->($config_file);
4878 ${$rconfig_file_chatter} .= "\n";
4882 # then look for a system-wide definition
4883 # where to look varies with OS
4886 if ($Windows_type) {
4887 my ( $os, $system, $allusers ) =
4888 Win_Config_Locs( $rpending_complaint, $Windows_type );
4890 # Check All Users directory, if there is one.
4891 # i.e. C:\Documents and Settings\User\perltidy.ini
4894 $config_file = catfile( $allusers, ".perltidyrc" );
4895 return $config_file if $exists_config_file->($config_file);
4897 $config_file = catfile( $allusers, "perltidy.ini" );
4898 return $config_file if $exists_config_file->($config_file);
4901 # Check system directory.
4902 # retain old code in case someone has been able to create
4903 # a file with a leading period.
4904 $config_file = catfile( $system, ".perltidyrc" );
4905 return $config_file if $exists_config_file->($config_file);
4907 $config_file = catfile( $system, "perltidy.ini" );
4908 return $config_file if $exists_config_file->($config_file);
4912 # Place to add customization code for other systems
4913 elsif ( $OSNAME eq 'OS2' ) {
4915 elsif ( $OSNAME eq 'MacOS' ) {
4917 elsif ( $OSNAME eq 'VMS' ) {
4920 # Assume some kind of Unix
4923 $config_file = "/usr/local/etc/perltidyrc";
4924 return $config_file if $exists_config_file->($config_file);
4926 $config_file = "/etc/perltidyrc";
4927 return $config_file if $exists_config_file->($config_file);
4930 # Couldn't find a config file
4932 } ## end sub find_config_file
4934 sub Win_Config_Locs {
4936 # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
4937 # or undef if its not a win32 OS. In list context returns OS, System
4938 # Directory, and All Users Directory. All Users will be empty on a
4939 # 9x/Me box. Contributed by: Yves Orton.
4941 my ( $rpending_complaint, $os ) = @_;
4942 if ( !$os ) { $os = Win_OS_Type(); }
4946 my $system = EMPTY_STRING;
4947 my $allusers = EMPTY_STRING;
4949 if ( $os =~ /9[58]|Me/ ) {
4950 $system = "C:/Windows";
4952 elsif ( $os =~ /NT|XP|200?/ ) {
4953 $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
4956 ? "C:/WinNT/profiles/All Users/"
4957 : "C:/Documents and Settings/All Users/";
4961 # This currently would only happen on a win32s computer. I don't have
4962 # one to test, so I am unsure how to proceed. Suggestions welcome!
4963 ${$rpending_complaint} .=
4964 "I dont know a sensible place to look for config files on an $os system.\n";
4967 return wantarray ? ( $os, $system, $allusers ) : $os;
4968 } ## end sub Win_Config_Locs
4970 sub dump_config_file {
4971 my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
4972 print STDOUT "${$rconfig_file_chatter}";
4974 print STDOUT "# Dump of file: '$config_file'\n";
4975 while ( my $line = $fh->getline() ) { print STDOUT $line }
4976 my $ok = eval { $fh->close(); 1 };
4977 if ( !$ok && DEVEL_MODE ) {
4978 Fault("Could not close file handle(): $EVAL_ERROR\n");
4982 print STDOUT "# ...no config file found\n";
4985 } ## end sub dump_config_file
4987 sub read_config_file {
4989 my ( $fh, $config_file, $rexpansion ) = @_;
4990 my @config_list = ();
4992 # file is bad if non-empty $death_message is returned
4993 my $death_message = EMPTY_STRING;
4997 my $opening_brace_line;
4998 while ( my $line = $fh->getline() ) {
5001 ( $line, $death_message ) =
5002 strip_comment( $line, $config_file, $line_no );
5003 last if ($death_message);
5005 $line =~ s/^\s*(.*?)\s*$/$1/; # trim both ends
5010 # Look for complete or partial abbreviation definition of the form
5011 # name { body } or name { or name { body
5012 # See rules in perltidy's perldoc page
5013 # Section: Other Controls - Creating a new abbreviation
5014 if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
5015 ( $name, $body ) = ( $2, $3 );
5017 # Cannot start new abbreviation unless old abbreviation is complete
5018 last if ($opening_brace_line);
5020 $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
5022 # handle a new alias definition
5023 if ( $rexpansion->{$name} ) {
5024 local $LIST_SEPARATOR = ')(';
5025 my @names = sort keys %{$rexpansion};
5027 "Here is a list of all installed aliases\n(@names)\n"
5028 . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n";
5031 $rexpansion->{$name} = [];
5034 # leading opening braces not allowed
5035 elsif ( $line =~ /^{/ ) {
5036 $opening_brace_line = undef;
5038 "Unexpected '{' at line $line_no in config file '$config_file'\n";
5042 # Look for abbreviation closing: body } or }
5043 elsif ( $line =~ /^(.*)?\}$/ ) {
5045 if ($opening_brace_line) {
5046 $opening_brace_line = undef;
5050 "Unexpected '}' at line $line_no in config file '$config_file'\n";
5055 # Now store any parameters
5058 my ( $rbody_parts, $msg ) = parse_args($body);
5060 $death_message = <<EOM;
5061 Error reading file '$config_file' at line number $line_no.
5063 Please fix this line or use -npro to avoid reading this file
5070 # remove leading dashes if this is an alias
5071 foreach ( @{$rbody_parts} ) { s/^\-+//; }
5072 push @{ $rexpansion->{$name} }, @{$rbody_parts};
5075 push( @config_list, @{$rbody_parts} );
5080 if ($opening_brace_line) {
5082 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
5084 my $ok = eval { $fh->close(); 1 };
5085 if ( !$ok && DEVEL_MODE ) {
5086 Fault("Could not close file handle(): $EVAL_ERROR\n");
5088 return ( \@config_list, $death_message );
5089 } ## end sub read_config_file
5093 # Strip any comment from a command line
5094 my ( $instr, $config_file, $line_no ) = @_;
5095 my $msg = EMPTY_STRING;
5097 # check for full-line comment
5098 if ( $instr =~ /^\s*#/ ) {
5099 return ( EMPTY_STRING, $msg );
5102 # nothing to do if no comments
5103 if ( $instr !~ /#/ ) {
5104 return ( $instr, $msg );
5107 # handle case of no quotes
5108 elsif ( $instr !~ /['"]/ ) {
5110 # We now require a space before the # of a side comment
5111 # this allows something like:
5113 # Otherwise, it would have to be quoted:
5115 $instr =~ s/\s+\#.*$//;
5116 return ( $instr, $msg );
5119 # handle comments and quotes
5120 my $outstr = EMPTY_STRING;
5121 my $quote_char = EMPTY_STRING;
5124 # looking for ending quote character
5126 if ( $instr =~ /\G($quote_char)/gc ) {
5127 $quote_char = EMPTY_STRING;
5130 elsif ( $instr =~ /\G(.)/gc ) {
5134 # error..we reached the end without seeing the ending quote char
5137 Error reading file $config_file at line number $line_no.
5138 Did not see ending quote character <$quote_char> in this text:
5140 Please fix this line or use -npro to avoid reading this file
5146 # accumulating characters and looking for start of a quoted string
5148 if ( $instr =~ /\G([\"\'])/gc ) {
5153 # Note: not yet enforcing the space-before-hash rule for side
5154 # comments if the parameter is quoted.
5155 elsif ( $instr =~ /\G#/gc ) {
5158 elsif ( $instr =~ /\G(.)/gc ) {
5166 return ( $outstr, $msg );
5167 } ## end sub strip_comment
5171 # Parse a command string containing multiple string with possible
5172 # quotes, into individual commands. It might look like this, for example:
5174 # -wba=" + - " -some-thing -wbb='. && ||'
5176 # There is no need, at present, to handle escaped quote characters.
5177 # (They are not perltidy tokens, so needn't be in strings).
5180 my @body_parts = ();
5181 my $quote_char = EMPTY_STRING;
5182 my $part = EMPTY_STRING;
5183 my $msg = EMPTY_STRING;
5185 # Check for external call with undefined $body - added to fix
5186 # github issue Perl-Tidy-Sweetened issue #23
5187 if ( !defined($body) ) { $body = EMPTY_STRING }
5191 # looking for ending quote character
5193 if ( $body =~ /\G($quote_char)/gc ) {
5194 $quote_char = EMPTY_STRING;
5196 elsif ( $body =~ /\G(.)/gc ) {
5200 # error..we reached the end without seeing the ending quote char
5202 if ( length($part) ) { push @body_parts, $part; }
5204 Did not see ending quote character <$quote_char> in this text:
5211 # accumulating characters and looking for start of a quoted string
5213 if ( $body =~ /\G([\"\'])/gc ) {
5216 elsif ( $body =~ /\G(\s+)/gc ) {
5217 if ( length($part) ) { push @body_parts, $part; }
5218 $part = EMPTY_STRING;
5220 elsif ( $body =~ /\G(.)/gc ) {
5224 if ( length($part) ) { push @body_parts, $part; }
5229 return ( \@body_parts, $msg );
5230 } ## end sub parse_args
5232 sub dump_long_names {
5236 # Command line long names (passed to GetOptions)
5237 #--------------------------------------------------
5238 # here is a summary of the Getopt codes:
5239 # <none> does not take an argument
5240 # =s takes a mandatory string
5241 # :s takes an optional string
5242 # =i takes a mandatory integer
5243 # :i takes an optional integer
5244 # ! does not take an argument and may be negated
5245 # i.e., -foo and -nofoo are allowed
5246 # a double dash signals the end of the options list
5248 #--------------------------------------------------
5251 foreach my $name ( sort @names ) { print STDOUT "$name\n" }
5253 } ## end sub dump_long_names
5257 print STDOUT "Default command line options:\n";
5258 foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
5260 } ## end sub dump_defaults
5262 sub readable_options {
5264 # return options for this run as a string which could be
5265 # put in a perltidyrc file
5266 my ( $rOpts, $roption_string ) = @_;
5268 my $rGetopt_flags = \%Getopt_flags;
5269 my $readable_options = "# Final parameter set for this run.\n";
5270 $readable_options .=
5271 "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
5272 foreach my $opt ( @{$roption_string} ) {
5273 my $flag = EMPTY_STRING;
5274 if ( $opt =~ /(.*)(!|=.*)$/ ) {
5278 if ( defined( $rOpts->{$opt} ) ) {
5279 $rGetopt_flags->{$opt} = $flag;
5282 foreach my $key ( sort keys %{$rOpts} ) {
5283 my $flag = $rGetopt_flags->{$key};
5284 my $value = $rOpts->{$key};
5286 my $suffix = EMPTY_STRING;
5288 if ( $flag =~ /^=/ ) {
5289 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
5290 $suffix = "=" . $value;
5292 elsif ( $flag =~ /^!/ ) {
5293 $prefix .= "no" unless ($value);
5298 $readable_options .=
5299 "# ERROR in dump_options: unrecognized flag $flag for $key\n";
5302 $readable_options .= $prefix . $key . $suffix . "\n";
5304 return $readable_options;
5305 } ## end sub readable_options
5308 print STDOUT <<"EOM";
5309 This is perltidy, v$VERSION
5311 Copyright 2000-2022, Steve Hancock
5313 Perltidy is free software and may be copied under the terms of the GNU
5314 General Public License, which is included in the distribution files.
5316 Complete documentation for perltidy can be found using 'man perltidy'
5317 or on the internet at http://perltidy.sourceforge.net.
5320 } ## end sub show_version
5325 This is perltidy version $VERSION, a perl script indenter. Usage:
5327 perltidy [ options ] file1 file2 file3 ...
5328 (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
5329 perltidy [ options ] file1 -o outfile
5330 perltidy [ options ] file1 -st >outfile
5331 perltidy [ options ] <infile >outfile
5333 Options have short and long forms. Short forms are shown; see
5334 man pages for long forms. Note: '=s' indicates a required string,
5335 and '=n' indicates a required integer.
5339 -o=file name of the output file (only if single input file)
5340 -oext=s change output extension from 'tdy' to s
5341 -opath=path change path to be 'path' for output files
5342 -b backup original to .bak and modify file in-place
5343 -bext=s change default backup extension from 'bak' to s
5344 -q deactivate error messages (for running under editor)
5345 -w include non-critical warning messages in the .ERR error output
5346 -log save .LOG file, which has useful diagnostics
5347 -f force perltidy to read a binary file
5348 -g like -log but writes more detailed .LOG file, for debugging scripts
5349 -opt write the set of options actually used to a .LOG file
5350 -npro ignore .perltidyrc configuration command file
5351 -pro=file read configuration commands from file instead of .perltidyrc
5352 -st send output to standard output, STDOUT
5353 -se send all error output to standard error output, STDERR
5354 -v display version number to standard output and quit
5357 -i=n use n columns per indentation level (default n=4)
5358 -t tabs: use one tab character per indentation level, not recommended
5359 -nt no tabs: use n spaces per indentation level (default)
5360 -et=n entab leading whitespace n spaces per tab; not recommended
5361 -io "indent only": just do indentation, no other formatting.
5362 -sil=n set starting indentation level to n; use if auto detection fails
5363 -ole=s specify output line ending (s=dos or win, mac, unix)
5364 -ple keep output line endings same as input (input must be filename)
5367 -fws freeze whitespace; this disables all whitespace changes
5368 and disables the following switches:
5369 -bt=n sets brace tightness, n= (0 = loose, 1=default, 2 = tight)
5370 -bbt same as -bt but for code block braces; same as -bt if not given
5371 -bbvt block braces vertically tight; use with -bl or -bli
5372 -bbvtl=s make -bbvt to apply to selected list of block types
5373 -pt=n paren tightness (n=0, 1 or 2)
5374 -sbt=n square bracket tightness (n=0, 1, or 2)
5375 -bvt=n brace vertical tightness,
5376 n=(0=open, 1=close unless multiple steps on a line, 2=always close)
5377 -pvt=n paren vertical tightness (see -bvt for n)
5378 -sbvt=n square bracket vertical tightness (see -bvt for n)
5379 -bvtc=n closing brace vertical tightness:
5380 n=(0=open, 1=sometimes close, 2=always close)
5381 -pvtc=n closing paren vertical tightness, see -bvtc for n.
5382 -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
5383 -ci=n sets continuation indentation=n, default is n=2 spaces
5384 -lp line up parentheses, brackets, and non-BLOCK braces
5385 -sfs add space before semicolon in for( ; ; )
5386 -aws allow perltidy to add whitespace (default)
5387 -dws delete all old non-essential whitespace
5388 -icb indent closing brace of a code block
5389 -cti=n closing indentation of paren, square bracket, or non-block brace:
5390 n=0 none, =1 align with opening, =2 one full indentation level
5391 -icp equivalent to -cti=2
5392 -wls=s want space left of tokens in string; i.e. -nwls='+ - * /'
5393 -wrs=s want space right of tokens in string;
5394 -sts put space before terminal semicolon of a statement
5395 -sak=s put space between keywords given in s and '(';
5396 -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
5399 -fnl freeze newlines; this disables all line break changes
5400 and disables the following switches:
5401 -anl add newlines; ok to introduce new line breaks
5402 -bbs add blank line before subs and packages
5403 -bbc add blank line before block comments
5404 -bbb add blank line between major blocks
5405 -kbl=n keep old blank lines? 0=no, 1=some, 2=all
5406 -mbl=n maximum consecutive blank lines to output (default=1)
5407 -ce cuddled else; use this style: '} else {'
5408 -cb cuddled blocks (other than 'if-elsif-else')
5409 -cbl=s list of blocks to cuddled, default 'try-catch-finally'
5410 -dnl delete old newlines (default)
5411 -l=n maximum line length; default n=80
5412 -bl opening brace on new line
5413 -sbl opening sub brace on new line. value of -bl is used if not given.
5414 -bli opening brace on new line and indented
5415 -bar opening brace always on right, even for long clauses
5416 -vt=n vertical tightness (requires -lp); n controls break after opening
5417 token: 0=never 1=no break if next line balanced 2=no break
5418 -vtc=n vertical tightness of closing container; n controls if closing
5419 token starts new line: 0=always 1=not unless list 1=never
5420 -wba=s want break after tokens in string; i.e. wba=': .'
5421 -wbb=s want break before tokens in string
5422 -wn weld nested: combines opening and closing tokens when both are adjacent
5423 -wnxl=s weld nested exclusion list: provides some control over the types of
5424 containers which can be welded
5426 Following Old Breakpoints
5427 -kis keep interior semicolons. Allows multiple statements per line.
5428 -boc break at old comma breaks: turns off all automatic list formatting
5429 -bol break at old logical breakpoints: or, and, ||, && (default)
5430 -bom break at old method call breakpoints: ->
5431 -bok break at old list keyword breakpoints such as map, sort (default)
5432 -bot break at old conditional (ternary ?:) operator breakpoints (default)
5433 -boa break at old attribute breakpoints
5434 -cab=n break at commas after a comma-arrow (=>):
5435 n=0 break at all commas after =>
5436 n=1 stable: break unless this breaks an existing one-line container
5437 n=2 break only if a one-line container cannot be formed
5438 n=3 do not treat commas after => specially at all
5441 -ibc indent block comments (default)
5442 -isbc indent spaced block comments; may indent unless no leading space
5443 -msc=n minimum desired spaces to side comment, default 4
5444 -fpsc=n fix position for side comments; default 0;
5445 -csc add or update closing side comments after closing BLOCK brace
5446 -dcsc delete closing side comments created by a -csc command
5447 -cscp=s change closing side comment prefix to be other than '## end'
5448 -cscl=s change closing side comment to apply to selected list of blocks
5449 -csci=n minimum number of lines needed to apply a -csc tag, default n=6
5450 -csct=n maximum number of columns of appended text, default n=20
5451 -cscw causes warning if old side comment is overwritten with -csc
5453 -sbc use 'static block comments' identified by leading '##' (default)
5454 -sbcp=s change static block comment identifier to be other than '##'
5455 -osbc outdent static block comments
5457 -ssc use 'static side comments' identified by leading '##' (default)
5458 -sscp=s change static side comment identifier to be other than '##'
5460 Delete selected text
5461 -dac delete all comments AND pod
5462 -dbc delete block comments
5463 -dsc delete side comments
5466 Send selected text to a '.TEE' file
5467 -tac tee all comments AND pod
5468 -tbc tee block comments
5469 -tsc tee side comments
5473 -olq outdent long quoted strings (default)
5474 -olc outdent a long block comment line
5475 -ola outdent statement labels
5476 -okw outdent control keywords (redo, next, last, goto, return)
5477 -okwl=s specify alternative keywords for -okw command
5480 -mft=n maximum fields per table; default n=0 (no limit)
5481 -x do not format lines before hash-bang line (i.e., for VMS)
5482 -asc allows perltidy to add a ';' when missing (default)
5483 -dsm allows perltidy to delete an unnecessary ';' (default)
5485 Combinations of other parameters
5486 -gnu attempt to follow GNU Coding Standards as applied to perl
5487 -mangle remove as many newlines as possible (but keep comments and pods)
5488 -extrude insert as many newlines as possible
5490 Dump and die, debugging
5491 -dop dump options used in this run to standard output and quit
5492 -ddf dump default options to standard output and quit
5493 -dsn dump all option short names to standard output and quit
5494 -dln dump option long names to standard output and quit
5495 -dpro dump whatever configuration file is in effect to standard output
5496 -dtt dump all token types to standard output and quit
5499 -html write an html file (see 'man perl2web' for many options)
5500 Note: when -html is used, no indentation or formatting are done.
5501 Hint: try perltidy -html -css=mystyle.css filename.pl
5502 and edit mystyle.css to change the appearance of filename.html.
5503 -nnn gives line numbers
5504 -pre only writes out <pre>..</pre> code section
5505 -toc places a table of contents to subs at the top (default)
5506 -pod passes pod text through pod2html (default)
5507 -frm write html as a frame (3 files)
5508 -text=s extra extension for table of contents if -frm, default='toc'
5509 -sext=s extra extension for file content if -frm, default='src'
5511 A prefix of "n" negates short form toggle switches, and a prefix of "no"
5512 negates the long forms. For example, -nasc means don't add missing
5515 If you are unable to see this entire text, try "perltidy -h | more"
5516 For more detailed information, and additional options, try "man perltidy",
5517 or go to the perltidy home page at http://perltidy.sourceforge.net