"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20190915/lib/Perl/Tidy.pm" (14 Sep 2019, 152504 Bytes) of package /linux/misc/Perl-Tidy-20190915.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Tidy.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20190601_vs_20190915.

    1 #
    2 ###########################################################-
    3 #
    4 #    perltidy - a perl script indenter and formatter
    5 #
    6 #    Copyright (c) 2000-2019 by Steve Hancock
    7 #    Distributed under the GPL license agreement; see file COPYING
    8 #
    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.
   13 #
   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.
   18 #
   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.
   22 #
   23 #    For brief instructions, try 'perltidy -h'.
   24 #    For more complete documentation, try 'man perltidy'
   25 #    or visit http://perltidy.sourceforge.net
   26 #
   27 #    This script is an example of the default style.  It was formatted with:
   28 #
   29 #      perltidy Tidy.pm
   30 #
   31 #    Code Contributions: See ChangeLog.html for a complete history.
   32 #      Michael Cartmell supplied code for adaptation to VMS and helped with
   33 #        v-strings.
   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
   42 #      entabbed code.
   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
   48 #      * iterations option
   49 #
   50 #      Many others have supplied key ideas, suggestions, and bug reports;
   51 #        see the CHANGES file.
   52 #
   53 ############################################################
   54 
   55 package Perl::Tidy;
   56 
   57 # perlver reports minimum version needed is 5.8.0
   58 # 5.004 needed for IO::File
   59 # 5.008 needed for wide characters
   60 use 5.008;
   61 use warnings;
   62 use strict;
   63 use Exporter;
   64 use Carp;
   65 use Digest::MD5 qw(md5_hex);
   66 use Perl::Tidy::Debugger;
   67 use Perl::Tidy::DevNull;
   68 use Perl::Tidy::Diagnostics;
   69 use Perl::Tidy::FileWriter;
   70 use Perl::Tidy::Formatter;
   71 use Perl::Tidy::HtmlWriter;
   72 use Perl::Tidy::IOScalar;
   73 use Perl::Tidy::IOScalarArray;
   74 use Perl::Tidy::IndentationItem;
   75 use Perl::Tidy::LineSink;
   76 use Perl::Tidy::LineSource;
   77 use Perl::Tidy::Logger;
   78 use Perl::Tidy::Tokenizer;
   79 use Perl::Tidy::VerticalAligner;
   80 local $| = 1;
   81 
   82 use vars qw{
   83   $VERSION
   84   @ISA
   85   @EXPORT
   86   $missing_file_spec
   87   $fh_stderr
   88   $rOpts_character_encoding
   89   $Warn_count
   90 };
   91 
   92 @ISA    = qw( Exporter );
   93 @EXPORT = qw( &perltidy );
   94 
   95 use Cwd;
   96 use Encode ();
   97 use IO::File;
   98 use File::Basename;
   99 use File::Copy;
  100 use File::Temp qw(tempfile);
  101 
  102 BEGIN {
  103 
  104     # Release version is the approximate YYMMDD of the release.
  105     # Development version is (Last Release).(Development Number)
  106 
  107     # To make the number continually increasing, the Development Number is a 2
  108     # digit number starting at 01 after a release is continually bumped along
  109     # at significant points during development. If it ever reaches 99 then the
  110     # Release version must be bumped, and it is probably past time for a
  111     # release anyway.
  112 
  113     $VERSION = '20190915';
  114 }
  115 
  116 sub streamhandle {
  117 
  118     # given filename and mode (r or w), create an object which:
  119     #   has a 'getline' method if mode='r', and
  120     #   has a 'print' method if mode='w'.
  121     # The objects also need a 'close' method.
  122     #
  123     # How the object is made:
  124     #
  125     # if $filename is:     Make object using:
  126     # ----------------     -----------------
  127     # '-'                  (STDIN if mode = 'r', STDOUT if mode='w')
  128     # string               IO::File
  129     # ARRAY  ref           Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
  130     # STRING ref           Perl::Tidy::IOScalar      (formerly IO::Scalar)
  131     # object               object
  132     #                      (check for 'print' method for 'w' mode)
  133     #                      (check for 'getline' method for 'r' mode)
  134     my ( $filename, $mode ) = @_;
  135 
  136     my $ref = ref($filename);
  137     my $New;
  138     my $fh;
  139 
  140     # handle a reference
  141     if ($ref) {
  142         if ( $ref eq 'ARRAY' ) {
  143             $New = sub { Perl::Tidy::IOScalarArray->new(@_) };
  144         }
  145         elsif ( $ref eq 'SCALAR' ) {
  146             $New = sub { Perl::Tidy::IOScalar->new(@_) };
  147         }
  148         else {
  149 
  150             # Accept an object with a getline method for reading. Note:
  151             # IO::File is built-in and does not respond to the defined
  152             # operator.  If this causes trouble, the check can be
  153             # skipped and we can just let it crash if there is no
  154             # getline.
  155             if ( $mode =~ /[rR]/ ) {
  156 
  157                 # RT#97159; part 1 of 2: updated to use 'can'
  158                 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
  159                 if ( $ref->can('getline') ) {
  160                     $New = sub { $filename };
  161                 }
  162                 else {
  163                     $New = sub { undef };
  164                     confess <<EOM;
  165 ------------------------------------------------------------------------
  166 No 'getline' method is defined for object of class $ref
  167 Please check your call to Perl::Tidy::perltidy.  Trace follows.
  168 ------------------------------------------------------------------------
  169 EOM
  170                 }
  171             }
  172 
  173             # Accept an object with a print method for writing.
  174             # See note above about IO::File
  175             if ( $mode =~ /[wW]/ ) {
  176 
  177                 # RT#97159; part 2 of 2: updated to use 'can'
  178                 ##if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
  179                 if ( $ref->can('print') ) {
  180                     $New = sub { $filename };
  181                 }
  182                 else {
  183                     $New = sub { undef };
  184                     confess <<EOM;
  185 ------------------------------------------------------------------------
  186 No 'print' method is defined for object of class $ref
  187 Please check your call to Perl::Tidy::perltidy. Trace follows.
  188 ------------------------------------------------------------------------
  189 EOM
  190                 }
  191             }
  192         }
  193     }
  194 
  195     # handle a string
  196     else {
  197         if ( $filename eq '-' ) {
  198             $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
  199         }
  200         else {
  201             $New = sub { IO::File->new(@_) };
  202         }
  203     }
  204     $fh = $New->( $filename, $mode )
  205       or Warn("Couldn't open file:$filename in mode:$mode : $!\n");
  206 
  207     return $fh, ( $ref or $filename );
  208 }
  209 
  210 sub find_input_line_ending {
  211 
  212     # Peek at a file and return first line ending character.
  213     # Return undefined value in case of any trouble.
  214     my ($input_file) = @_;
  215     my $ending;
  216 
  217     # silently ignore input from object or stdin
  218     if ( ref($input_file) || $input_file eq '-' ) {
  219         return $ending;
  220     }
  221 
  222     my $fh;
  223     open( $fh, '<', $input_file ) || return $ending;
  224 
  225     binmode $fh;
  226     my $buf;
  227     read( $fh, $buf, 1024 );
  228     close $fh;
  229     if ( $buf && $buf =~ /([\012\015]+)/ ) {
  230         my $test = $1;
  231 
  232         # dos
  233         if ( $test =~ /^(\015\012)+$/ ) { $ending = "\015\012" }
  234 
  235         # mac
  236         elsif ( $test =~ /^\015+$/ ) { $ending = "\015" }
  237 
  238         # unix
  239         elsif ( $test =~ /^\012+$/ ) { $ending = "\012" }
  240 
  241         # unknown
  242         else { }
  243     }
  244 
  245     # no ending seen
  246     else { }
  247 
  248     return $ending;
  249 }
  250 
  251 sub catfile {
  252 
  253     # concatenate a path and file basename
  254     # returns undef in case of error
  255 
  256     my @parts = @_;
  257 
  258     BEGIN {
  259         eval { require File::Spec };
  260         $missing_file_spec = $@;
  261     }
  262 
  263     # use File::Spec if we can
  264     unless ($missing_file_spec) {
  265         return File::Spec->catfile(@parts);
  266     }
  267 
  268     # Perl 5.004 systems may not have File::Spec so we'll make
  269     # a simple try.  We assume File::Basename is available.
  270     # return if not successful.
  271     my $name      = pop @parts;
  272     my $path      = join '/', @parts;
  273     my $test_file = $path . $name;
  274     my ( $test_name, $test_path ) = fileparse($test_file);
  275     return $test_file if ( $test_name eq $name );
  276     return if ( $^O eq 'VMS' );
  277 
  278     # this should work at least for Windows and Unix:
  279     $test_file = $path . '/' . $name;
  280     ( $test_name, $test_path ) = fileparse($test_file);
  281     return $test_file if ( $test_name eq $name );
  282     return;
  283 }
  284 
  285 # Here is a map of the flow of data from the input source to the output
  286 # line sink:
  287 #
  288 # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
  289 #       input                         groups                 output
  290 #       lines   tokens      lines       of          lines    lines
  291 #                                      lines
  292 #
  293 # The names correspond to the package names responsible for the unit processes.
  294 #
  295 # The overall process is controlled by the "main" package.
  296 #
  297 # LineSource is the stream of input lines
  298 #
  299 # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
  300 # if necessary.  A token is any section of the input line which should be
  301 # manipulated as a single entity during formatting.  For example, a single
  302 # ',' character is a token, and so is an entire side comment.  It handles
  303 # the complexities of Perl syntax, such as distinguishing between '<<' as
  304 # a shift operator and as a here-document, or distinguishing between '/'
  305 # as a divide symbol and as a pattern delimiter.
  306 #
  307 # Formatter inserts and deletes whitespace between tokens, and breaks
  308 # sequences of tokens at appropriate points as output lines.  It bases its
  309 # decisions on the default rules as modified by any command-line options.
  310 #
  311 # VerticalAligner collects groups of lines together and tries to line up
  312 # certain tokens, such as '=>', '#', and '=' by adding whitespace.
  313 #
  314 # FileWriter simply writes lines to the output stream.
  315 #
  316 # The Logger package, not shown, records significant events and warning
  317 # messages.  It writes a .LOG file, which may be saved with a
  318 # '-log' or a '-g' flag.
  319 
  320 sub perltidy {
  321 
  322     my %input_hash = @_;
  323 
  324     my %defaults = (
  325         argv                  => undef,
  326         destination           => undef,
  327         formatter             => undef,
  328         logfile               => undef,
  329         errorfile             => undef,
  330         perltidyrc            => undef,
  331         source                => undef,
  332         stderr                => undef,
  333         dump_options          => undef,
  334         dump_options_type     => undef,
  335         dump_getopt_flags     => undef,
  336         dump_options_category => undef,
  337         dump_options_range    => undef,
  338         dump_abbreviations    => undef,
  339         prefilter             => undef,
  340         postfilter            => undef,
  341     );
  342 
  343     # don't overwrite callers ARGV
  344     local @ARGV   = @ARGV;
  345     local *STDERR = *STDERR;
  346 
  347     if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
  348         local $" = ')(';
  349         my @good_keys = sort keys %defaults;
  350         @bad_keys = sort @bad_keys;
  351         confess <<EOM;
  352 ------------------------------------------------------------------------
  353 Unknown perltidy parameter : (@bad_keys)
  354 perltidy only understands : (@good_keys)
  355 ------------------------------------------------------------------------
  356 
  357 EOM
  358     }
  359 
  360     my $get_hash_ref = sub {
  361         my ($key) = @_;
  362         my $hash_ref = $input_hash{$key};
  363         if ( defined($hash_ref) ) {
  364             unless ( ref($hash_ref) eq 'HASH' ) {
  365                 my $what = ref($hash_ref);
  366                 my $but_is =
  367                   $what ? "but is ref to $what" : "but is not a reference";
  368                 croak <<EOM;
  369 ------------------------------------------------------------------------
  370 error in call to perltidy:
  371 -$key must be reference to HASH $but_is
  372 ------------------------------------------------------------------------
  373 EOM
  374             }
  375         }
  376         return $hash_ref;
  377     };
  378 
  379     %input_hash = ( %defaults, %input_hash );
  380     my $argv               = $input_hash{'argv'};
  381     my $destination_stream = $input_hash{'destination'};
  382     my $errorfile_stream   = $input_hash{'errorfile'};
  383     my $logfile_stream     = $input_hash{'logfile'};
  384     my $perltidyrc_stream  = $input_hash{'perltidyrc'};
  385     my $source_stream      = $input_hash{'source'};
  386     my $stderr_stream      = $input_hash{'stderr'};
  387     my $user_formatter     = $input_hash{'formatter'};
  388     my $prefilter          = $input_hash{'prefilter'};
  389     my $postfilter         = $input_hash{'postfilter'};
  390 
  391     if ($stderr_stream) {
  392         ( $fh_stderr, my $stderr_file ) =
  393           Perl::Tidy::streamhandle( $stderr_stream, 'w' );
  394         if ( !$fh_stderr ) {
  395             croak <<EOM;
  396 ------------------------------------------------------------------------
  397 Unable to redirect STDERR to $stderr_stream
  398 Please check value of -stderr in call to perltidy
  399 ------------------------------------------------------------------------
  400 EOM
  401         }
  402     }
  403     else {
  404         $fh_stderr = *STDERR;
  405     }
  406 
  407     sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return }
  408 
  409     sub Exit {
  410         my $flag = shift;
  411         if   ($flag) { goto ERROR_EXIT }
  412         else         { goto NORMAL_EXIT }
  413         croak "unexpectd return to Exit";
  414     }
  415 
  416     sub Die {
  417         my $msg = shift;
  418         Warn($msg);
  419         Exit(1);
  420         croak "unexpected return to Die";
  421     }
  422 
  423     my $md5_hex = sub {
  424         my ($buf) = @_;
  425 
  426         # Evaluate the MD5 sum for a string
  427         # Patch for [rt.cpan.org #88020]
  428         # Use utf8::encode since md5_hex() only operates on bytes.
  429         # my $digest = md5_hex( utf8::encode($sink_buffer) );
  430 
  431         # Note added 20180114: the above patch did not work correctly.  I'm not
  432         # sure why.  But switching to the method recommended in the Perl 5
  433         # documentation for Encode worked.  According to this we can either use
  434         #    $octets = encode_utf8($string)  or equivalently
  435         #    $octets = encode("utf8",$string)
  436         # and then calculate the checksum.  So:
  437         my $octets = Encode::encode( "utf8", $buf );
  438         my $digest = md5_hex($octets);
  439         return $digest;
  440     };
  441 
  442     # extract various dump parameters
  443     my $dump_options_type     = $input_hash{'dump_options_type'};
  444     my $dump_options          = $get_hash_ref->('dump_options');
  445     my $dump_getopt_flags     = $get_hash_ref->('dump_getopt_flags');
  446     my $dump_options_category = $get_hash_ref->('dump_options_category');
  447     my $dump_abbreviations    = $get_hash_ref->('dump_abbreviations');
  448     my $dump_options_range    = $get_hash_ref->('dump_options_range');
  449 
  450     # validate dump_options_type
  451     if ( defined($dump_options) ) {
  452         unless ( defined($dump_options_type) ) {
  453             $dump_options_type = 'perltidyrc';
  454         }
  455         unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) {
  456             croak <<EOM;
  457 ------------------------------------------------------------------------
  458 Please check value of -dump_options_type in call to perltidy;
  459 saw: '$dump_options_type' 
  460 expecting: 'perltidyrc' or 'full'
  461 ------------------------------------------------------------------------
  462 EOM
  463 
  464         }
  465     }
  466     else {
  467         $dump_options_type = "";
  468     }
  469 
  470     if ($user_formatter) {
  471 
  472         # if the user defines a formatter, there is no output stream,
  473         # but we need a null stream to keep coding simple
  474         $destination_stream = Perl::Tidy::DevNull->new();
  475     }
  476 
  477     # see if ARGV is overridden
  478     if ( defined($argv) ) {
  479 
  480         my $rargv = ref $argv;
  481         if ( $rargv eq 'SCALAR' ) { $argv = ${$argv}; $rargv = undef }
  482 
  483         # ref to ARRAY
  484         if ($rargv) {
  485             if ( $rargv eq 'ARRAY' ) {
  486                 @ARGV = @{$argv};
  487             }
  488             else {
  489                 croak <<EOM;
  490 ------------------------------------------------------------------------
  491 Please check value of -argv in call to perltidy;
  492 it must be a string or ref to ARRAY but is: $rargv
  493 ------------------------------------------------------------------------
  494 EOM
  495             }
  496         }
  497 
  498         # string
  499         else {
  500             my ( $rargv, $msg ) = parse_args($argv);
  501             if ($msg) {
  502                 Die(<<EOM);
  503 Error parsing this string passed to to perltidy with 'argv': 
  504 $msg
  505 EOM
  506             }
  507             @ARGV = @{$rargv};
  508         }
  509     }
  510 
  511     my $rpending_complaint;
  512     ${$rpending_complaint} = "";
  513     my $rpending_logfile_message;
  514     ${$rpending_logfile_message} = "";
  515 
  516     my ( $is_Windows, $Windows_type ) = look_for_Windows($rpending_complaint);
  517 
  518     # VMS file names are restricted to a 40.40 format, so we append _tdy
  519     # instead of .tdy, etc. (but see also sub check_vms_filename)
  520     my $dot;
  521     my $dot_pattern;
  522     if ( $^O eq 'VMS' ) {
  523         $dot         = '_';
  524         $dot_pattern = '_';
  525     }
  526     else {
  527         $dot         = '.';
  528         $dot_pattern = '\.';    # must escape for use in regex
  529     }
  530 
  531     #---------------------------------------------------------------
  532     # get command line options
  533     #---------------------------------------------------------------
  534     my ( $rOpts, $config_file, $rraw_options, $roption_string,
  535         $rexpansion, $roption_category, $roption_range )
  536       = process_command_line(
  537         $perltidyrc_stream,  $is_Windows, $Windows_type,
  538         $rpending_complaint, $dump_options_type,
  539       );
  540 
  541     my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0;
  542     my $saw_pbp =
  543       ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0;
  544 
  545     #---------------------------------------------------------------
  546     # Handle requests to dump information
  547     #---------------------------------------------------------------
  548 
  549     # return or exit immediately after all dumps
  550     my $quit_now = 0;
  551 
  552     # Getopt parameters and their flags
  553     if ( defined($dump_getopt_flags) ) {
  554         $quit_now = 1;
  555         foreach my $op ( @{$roption_string} ) {
  556             my $opt  = $op;
  557             my $flag = "";
  558 
  559             # Examples:
  560             #  some-option=s
  561             #  some-option=i
  562             #  some-option:i
  563             #  some-option!
  564             if ( $opt =~ /(.*)(!|=.*|:.*)$/ ) {
  565                 $opt  = $1;
  566                 $flag = $2;
  567             }
  568             $dump_getopt_flags->{$opt} = $flag;
  569         }
  570     }
  571 
  572     if ( defined($dump_options_category) ) {
  573         $quit_now = 1;
  574         %{$dump_options_category} = %{$roption_category};
  575     }
  576 
  577     if ( defined($dump_options_range) ) {
  578         $quit_now = 1;
  579         %{$dump_options_range} = %{$roption_range};
  580     }
  581 
  582     if ( defined($dump_abbreviations) ) {
  583         $quit_now = 1;
  584         %{$dump_abbreviations} = %{$rexpansion};
  585     }
  586 
  587     if ( defined($dump_options) ) {
  588         $quit_now = 1;
  589         %{$dump_options} = %{$rOpts};
  590     }
  591 
  592     Exit(0) if ($quit_now);
  593 
  594     # make printable string of options for this run as possible diagnostic
  595     my $readable_options = readable_options( $rOpts, $roption_string );
  596 
  597     # dump from command line
  598     if ( $rOpts->{'dump-options'} ) {
  599         print STDOUT $readable_options;
  600         Exit(0);
  601     }
  602 
  603     #---------------------------------------------------------------
  604     # check parameters and their interactions
  605     #---------------------------------------------------------------
  606     my $tabsize =
  607       check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint );
  608 
  609     if ($user_formatter) {
  610         $rOpts->{'format'} = 'user';
  611     }
  612 
  613     # there must be one entry here for every possible format
  614     my %default_file_extension = (
  615         tidy => 'tdy',
  616         html => 'html',
  617         user => '',
  618     );
  619 
  620     $rOpts_character_encoding = $rOpts->{'character-encoding'};
  621 
  622     # be sure we have a valid output format
  623     unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
  624         my $formats = join ' ',
  625           sort map { "'" . $_ . "'" } keys %default_file_extension;
  626         my $fmt = $rOpts->{'format'};
  627         Die("-format='$fmt' but must be one of: $formats\n");
  628     }
  629 
  630     my $output_extension = make_extension( $rOpts->{'output-file-extension'},
  631         $default_file_extension{ $rOpts->{'format'} }, $dot );
  632 
  633     # If the backup extension contains a / character then the backup should
  634     # be deleted when the -b option is used.   On older versions of
  635     # perltidy this will generate an error message due to an illegal
  636     # file name.
  637     #
  638     # A backup file will still be generated but will be deleted
  639     # at the end.  If -bext='/' then this extension will be
  640     # the default 'bak'.  Otherwise it will be whatever characters
  641     # remains after all '/' characters are removed.  For example:
  642     # -bext         extension     slashes
  643     #  '/'          bak           1
  644     #  '/delete'    delete        1
  645     #  'delete/'    delete        1
  646     #  '/dev/null'  devnull       2    (Currently not allowed)
  647     my $bext          = $rOpts->{'backup-file-extension'};
  648     my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g );
  649 
  650     # At present only one forward slash is allowed.  In the future multiple
  651     # slashes may be allowed to allow for other options
  652     if ( $delete_backup > 1 ) {
  653         Die("-bext=$bext contains more than one '/'\n");
  654     }
  655 
  656     my $backup_extension =
  657       make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
  658 
  659     my $html_toc_extension =
  660       make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
  661 
  662     my $html_src_extension =
  663       make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
  664 
  665     # check for -b option;
  666     # silently ignore unless beautify mode
  667     my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
  668       && $rOpts->{'format'} eq 'tidy';
  669 
  670     # Turn off -b with warnings in case of conflicts with other options.
  671     # NOTE: Do this silently, without warnings, if there is a source or
  672     # destination stream, or standard output is used.  This is because the -b
  673     # flag may have been in a .perltidyrc file and warnings break
  674     # Test::NoWarnings.  See email discussion with Merijn Brand 26 Feb 2014.
  675     if ($in_place_modify) {
  676         if (   $rOpts->{'standard-output'}
  677             || $destination_stream
  678             || ref $source_stream
  679             || $rOpts->{'outfile'}
  680             || defined( $rOpts->{'output-path'} ) )
  681         {
  682             $in_place_modify = 0;
  683         }
  684     }
  685 
  686     Perl::Tidy::Formatter::check_options($rOpts);
  687     if ( $rOpts->{'format'} eq 'html' ) {
  688         Perl::Tidy::HtmlWriter->check_options($rOpts);
  689     }
  690 
  691     # make the pattern of file extensions that we shouldn't touch
  692     my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)";
  693     if ($output_extension) {
  694         my $ext = quotemeta($output_extension);
  695         $forbidden_file_extensions .= "|$ext";
  696     }
  697     if ( $in_place_modify && $backup_extension ) {
  698         my $ext = quotemeta($backup_extension);
  699         $forbidden_file_extensions .= "|$ext";
  700     }
  701     $forbidden_file_extensions .= ')$';
  702 
  703     # Create a diagnostics object if requested;
  704     # This is only useful for code development
  705     my $diagnostics_object = undef;
  706     if ( $rOpts->{'DIAGNOSTICS'} ) {
  707         $diagnostics_object = Perl::Tidy::Diagnostics->new();
  708     }
  709 
  710     # no filenames should be given if input is from an array
  711     if ($source_stream) {
  712         if ( @ARGV > 0 ) {
  713             Die(
  714 "You may not specify any filenames when a source array is given\n"
  715             );
  716         }
  717 
  718         # we'll stuff the source array into ARGV
  719         unshift( @ARGV, $source_stream );
  720 
  721         # No special treatment for source stream which is a filename.
  722         # This will enable checks for binary files and other bad stuff.
  723         $source_stream = undef unless ref($source_stream);
  724     }
  725 
  726     # use stdin by default if no source array and no args
  727     else {
  728         unshift( @ARGV, '-' ) unless @ARGV;
  729     }
  730 
  731     #---------------------------------------------------------------
  732     # Ready to go...
  733     # main loop to process all files in argument list
  734     #---------------------------------------------------------------
  735     my $number_of_files = @ARGV;
  736     my $formatter       = undef;
  737     my $tokenizer       = undef;
  738 
  739     # If requested, process in order of increasing file size
  740     # This can significantly reduce perl's virtual memory usage during testing.
  741     if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) {
  742         @ARGV =
  743           map  { $_->[0] }
  744           sort { $a->[1] <=> $b->[1] }
  745           map  { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV;
  746     }
  747 
  748     while ( my $input_file = shift @ARGV ) {
  749         my $fileroot;
  750         my @input_file_stat;
  751         my $display_name;
  752 
  753         #---------------------------------------------------------------
  754         # prepare this input stream
  755         #---------------------------------------------------------------
  756         if ($source_stream) {
  757             $fileroot     = "perltidy";
  758             $display_name = "<source_stream>";
  759 
  760             # If the source is from an array or string, then .LOG output
  761             # is only possible if a logfile stream is specified.  This prevents
  762             # unexpected perltidy.LOG files.
  763             if ( !defined($logfile_stream) ) {
  764                 $logfile_stream = Perl::Tidy::DevNull->new();
  765             }
  766         }
  767         elsif ( $input_file eq '-' ) {    # '-' indicates input from STDIN
  768             $fileroot     = "perltidy";   # root name to use for .ERR, .LOG, etc
  769             $display_name = "<stdin>";
  770             $in_place_modify = 0;
  771         }
  772         else {
  773             $fileroot     = $input_file;
  774             $display_name = $input_file;
  775             unless ( -e $input_file ) {
  776 
  777                 # file doesn't exist - check for a file glob
  778                 if ( $input_file =~ /([\?\*\[\{])/ ) {
  779 
  780                     # Windows shell may not remove quotes, so do it
  781                     my $input_file = $input_file;
  782                     if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
  783                     if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
  784                     my $pattern = fileglob_to_re($input_file);
  785                     ##eval "/$pattern/";
  786                     if ( !$@ && opendir( DIR, './' ) ) {
  787                         my @files =
  788                           grep { /$pattern/ && !-d $_ } readdir(DIR);
  789                         closedir(DIR);
  790                         if (@files) {
  791                             unshift @ARGV, @files;
  792                             next;
  793                         }
  794                     }
  795                 }
  796                 Warn("skipping file: '$input_file': no matches found\n");
  797                 next;
  798             }
  799 
  800             unless ( -f $input_file ) {
  801                 Warn("skipping file: $input_file: not a regular file\n");
  802                 next;
  803             }
  804 
  805             # As a safety precaution, skip zero length files.
  806             # If for example a source file got clobbered somehow,
  807             # the old .tdy or .bak files might still exist so we
  808             # shouldn't overwrite them with zero length files.
  809             unless ( -s $input_file ) {
  810                 Warn("skipping file: $input_file: Zero size\n");
  811                 next;
  812             }
  813 
  814             unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
  815                 Warn(
  816                     "skipping file: $input_file: Non-text (override with -f)\n"
  817                 );
  818                 next;
  819             }
  820 
  821             # we should have a valid filename now
  822             $fileroot        = $input_file;
  823             @input_file_stat = stat($input_file);
  824 
  825             if ( $^O eq 'VMS' ) {
  826                 ( $fileroot, $dot ) = check_vms_filename($fileroot);
  827             }
  828 
  829             # add option to change path here
  830             if ( defined( $rOpts->{'output-path'} ) ) {
  831 
  832                 my ( $base, $old_path ) = fileparse($fileroot);
  833                 my $new_path = $rOpts->{'output-path'};
  834                 unless ( -d $new_path ) {
  835                     unless ( mkdir $new_path, 0777 ) {
  836                         Die("unable to create directory $new_path: $!\n");
  837                     }
  838                 }
  839                 my $path = $new_path;
  840                 $fileroot = catfile( $path, $base );
  841                 unless ($fileroot) {
  842                     Die(<<EOM);
  843 ------------------------------------------------------------------------
  844 Problem combining $new_path and $base to make a filename; check -opath
  845 ------------------------------------------------------------------------
  846 EOM
  847                 }
  848             }
  849         }
  850 
  851         # Skip files with same extension as the output files because
  852         # this can lead to a messy situation with files like
  853         # script.tdy.tdy.tdy ... or worse problems ...  when you
  854         # rerun perltidy over and over with wildcard input.
  855         if (
  856             !$source_stream
  857             && (   $input_file =~ /$forbidden_file_extensions/o
  858                 || $input_file eq 'DIAGNOSTICS' )
  859           )
  860         {
  861             Warn("skipping file: $input_file: wrong extension\n");
  862             next;
  863         }
  864 
  865         # the 'source_object' supplies a method to read the input file
  866         my $source_object =
  867           Perl::Tidy::LineSource->new( $input_file, $rOpts,
  868             $rpending_logfile_message );
  869         next unless ($source_object);
  870 
  871         my $max_iterations      = $rOpts->{'iterations'};
  872         my $do_convergence_test = $max_iterations > 1;
  873         my $convergence_log_message;
  874         my %saw_md5;
  875         my $digest_input = 0;
  876 
  877         # Prefilters and postfilters: The prefilter is a code reference
  878         # that will be applied to the source before tidying, and the
  879         # postfilter is a code reference to the result before outputting.
  880         if (
  881             $prefilter
  882             || (   $rOpts_character_encoding
  883                 && $rOpts_character_encoding eq 'utf8' )
  884             || $rOpts->{'assert-tidy'}
  885             || $rOpts->{'assert-untidy'}
  886             || $do_convergence_test
  887           )
  888         {
  889             my $buf = '';
  890             while ( my $line = $source_object->get_line() ) {
  891                 $buf .= $line;
  892             }
  893 
  894             if (   $rOpts_character_encoding
  895                 && $rOpts_character_encoding eq 'utf8'
  896                 && !utf8::is_utf8($buf) )
  897             {
  898                 eval {
  899                     $buf = Encode::decode( 'UTF-8', $buf,
  900                         Encode::FB_CROAK | Encode::LEAVE_SRC );
  901                 };
  902                 if ($@) {
  903                     Warn(
  904 "skipping file: $input_file: Unable to decode source as UTF-8\n"
  905                     );
  906                     next;
  907                 }
  908             }
  909 
  910             # MD5 sum of input file is evaluated before any prefilter
  911             if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) {
  912                 $digest_input = $md5_hex->($buf);
  913             }
  914 
  915             $buf = $prefilter->($buf) if $prefilter;
  916 
  917         # starting MD5 sum for convergence test is evaluated after any prefilter
  918             if ($do_convergence_test) {
  919                 my $digest = $md5_hex->($buf);
  920                 $saw_md5{$digest} = 1;
  921             }
  922 
  923             $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts,
  924                 $rpending_logfile_message );
  925         }
  926 
  927         # register this file name with the Diagnostics package
  928         $diagnostics_object->set_input_file($input_file)
  929           if $diagnostics_object;
  930 
  931         #---------------------------------------------------------------
  932         # prepare the output stream
  933         #---------------------------------------------------------------
  934         my $output_file = undef;
  935         my $actual_output_extension;
  936 
  937         if ( $rOpts->{'outfile'} ) {
  938 
  939             if ( $number_of_files <= 1 ) {
  940 
  941                 if ( $rOpts->{'standard-output'} ) {
  942                     my $msg = "You may not use -o and -st together";
  943                     $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
  944                     Die("$msg\n");
  945                 }
  946                 elsif ($destination_stream) {
  947                     Die(
  948 "You may not specify a destination array and -o together\n"
  949                     );
  950                 }
  951                 elsif ( defined( $rOpts->{'output-path'} ) ) {
  952                     Die("You may not specify -o and -opath together\n");
  953                 }
  954                 elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
  955                     Die("You may not specify -o and -oext together\n");
  956                 }
  957                 $output_file = $rOpts->{outfile};
  958 
  959                 # make sure user gives a file name after -o
  960                 if ( $output_file =~ /^-/ ) {
  961                     Die("You must specify a valid filename after -o\n");
  962                 }
  963 
  964                 # do not overwrite input file with -o
  965                 if ( @input_file_stat && ( $output_file eq $input_file ) ) {
  966                     Die("Use 'perltidy -b $input_file' to modify in-place\n");
  967                 }
  968             }
  969             else {
  970                 Die("You may not use -o with more than one input file\n");
  971             }
  972         }
  973         elsif ( $rOpts->{'standard-output'} ) {
  974             if ($destination_stream) {
  975                 my $msg =
  976                   "You may not specify a destination array and -st together\n";
  977                 $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp);
  978                 Die("$msg\n");
  979             }
  980             $output_file = '-';
  981 
  982             if ( $number_of_files <= 1 ) {
  983             }
  984             else {
  985                 Die("You may not use -st with more than one input file\n");
  986             }
  987         }
  988         elsif ($destination_stream) {
  989             $output_file = $destination_stream;
  990         }
  991         elsif ($source_stream) {    # source but no destination goes to stdout
  992             $output_file = '-';
  993         }
  994         elsif ( $input_file eq '-' ) {
  995             $output_file = '-';
  996         }
  997         else {
  998             if ($in_place_modify) {
  999                 $output_file = IO::File->new_tmpfile()
 1000                   or Die("cannot open temp file for -b option: $!\n");
 1001             }
 1002             else {
 1003                 $actual_output_extension = $output_extension;
 1004                 $output_file             = $fileroot . $output_extension;
 1005             }
 1006         }
 1007 
 1008         # the 'sink_object' knows how to write the output file
 1009         my $tee_file = $fileroot . $dot . "TEE";
 1010 
 1011         my $line_separator = $rOpts->{'output-line-ending'};
 1012         if ( $rOpts->{'preserve-line-endings'} ) {
 1013             $line_separator = find_input_line_ending($input_file);
 1014         }
 1015 
 1016         # Eventually all I/O may be done with binmode, but for now it is
 1017         # only done when a user requests a particular line separator
 1018         # through the -ple or -ole flags
 1019         my $binmode = defined($line_separator)
 1020           || defined($rOpts_character_encoding);
 1021         $line_separator = "\n" unless defined($line_separator);
 1022 
 1023         my ( $sink_object, $postfilter_buffer );
 1024         if (   $postfilter
 1025             || $rOpts->{'assert-tidy'}
 1026             || $rOpts->{'assert-untidy'} )
 1027         {
 1028             $sink_object =
 1029               Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file,
 1030                 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
 1031         }
 1032         else {
 1033             $sink_object =
 1034               Perl::Tidy::LineSink->new( $output_file, $tee_file,
 1035                 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
 1036         }
 1037 
 1038         #---------------------------------------------------------------
 1039         # initialize the error logger for this file
 1040         #---------------------------------------------------------------
 1041         my $warning_file = $fileroot . $dot . "ERR";
 1042         if ($errorfile_stream) { $warning_file = $errorfile_stream }
 1043         my $log_file = $fileroot . $dot . "LOG";
 1044         if ($logfile_stream) { $log_file = $logfile_stream }
 1045 
 1046         my $logger_object =
 1047           Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
 1048             $fh_stderr, $saw_extrude, $display_name );
 1049         write_logfile_header(
 1050             $rOpts,        $logger_object, $config_file,
 1051             $rraw_options, $Windows_type,  $readable_options,
 1052         );
 1053         if ( ${$rpending_logfile_message} ) {
 1054             $logger_object->write_logfile_entry( ${$rpending_logfile_message} );
 1055         }
 1056         if ( ${$rpending_complaint} ) {
 1057             $logger_object->complain( ${$rpending_complaint} );
 1058         }
 1059 
 1060         #---------------------------------------------------------------
 1061         # initialize the debug object, if any
 1062         #---------------------------------------------------------------
 1063         my $debugger_object = undef;
 1064         if ( $rOpts->{DEBUG} ) {
 1065             $debugger_object =
 1066               Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
 1067         }
 1068 
 1069         #---------------------------------------------------------------
 1070         # loop over iterations for one source stream
 1071         #---------------------------------------------------------------
 1072 
 1073         # save objects to allow redirecting output during iterations
 1074         my $sink_object_final     = $sink_object;
 1075         my $debugger_object_final = $debugger_object;
 1076         my $logger_object_final   = $logger_object;
 1077 
 1078         foreach my $iter ( 1 .. $max_iterations ) {
 1079 
 1080             # send output stream to temp buffers until last iteration
 1081             my $sink_buffer;
 1082             if ( $iter < $max_iterations ) {
 1083                 $sink_object =
 1084                   Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file,
 1085                     $line_separator, $rOpts, $rpending_logfile_message,
 1086                     $binmode );
 1087             }
 1088             else {
 1089                 $sink_object = $sink_object_final;
 1090             }
 1091 
 1092             # Save logger, debugger output only on pass 1 because:
 1093             # (1) line number references must be to the starting
 1094             # source, not an intermediate result, and
 1095             # (2) we need to know if there are errors so we can stop the
 1096             # iterations early if necessary.
 1097             if ( $iter > 1 ) {
 1098                 $debugger_object = undef;
 1099                 $logger_object   = undef;
 1100             }
 1101 
 1102             #------------------------------------------------------------
 1103             # create a formatter for this file : html writer or
 1104             # pretty printer
 1105             #------------------------------------------------------------
 1106 
 1107             # we have to delete any old formatter because, for safety,
 1108             # the formatter will check to see that there is only one.
 1109             $formatter = undef;
 1110 
 1111             if ($user_formatter) {
 1112                 $formatter = $user_formatter;
 1113             }
 1114             elsif ( $rOpts->{'format'} eq 'html' ) {
 1115                 $formatter =
 1116                   Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
 1117                     $actual_output_extension, $html_toc_extension,
 1118                     $html_src_extension );
 1119             }
 1120             elsif ( $rOpts->{'format'} eq 'tidy' ) {
 1121                 $formatter = Perl::Tidy::Formatter->new(
 1122                     logger_object      => $logger_object,
 1123                     diagnostics_object => $diagnostics_object,
 1124                     sink_object        => $sink_object,
 1125                 );
 1126             }
 1127             else {
 1128                 Die("I don't know how to do -format=$rOpts->{'format'}\n");
 1129             }
 1130 
 1131             unless ($formatter) {
 1132                 Die("Unable to continue with $rOpts->{'format'} formatting\n");
 1133             }
 1134 
 1135             #---------------------------------------------------------------
 1136             # create the tokenizer for this file
 1137             #---------------------------------------------------------------
 1138             $tokenizer = undef;                     # must destroy old tokenizer
 1139             $tokenizer = Perl::Tidy::Tokenizer->new(
 1140                 source_object      => $source_object,
 1141                 logger_object      => $logger_object,
 1142                 debugger_object    => $debugger_object,
 1143                 diagnostics_object => $diagnostics_object,
 1144                 tabsize            => $tabsize,
 1145 
 1146                 starting_level      => $rOpts->{'starting-indentation-level'},
 1147                 indent_columns      => $rOpts->{'indent-columns'},
 1148                 look_for_hash_bang  => $rOpts->{'look-for-hash-bang'},
 1149                 look_for_autoloader => $rOpts->{'look-for-autoloader'},
 1150                 look_for_selfloader => $rOpts->{'look-for-selfloader'},
 1151                 trim_qw             => $rOpts->{'trim-qw'},
 1152                 extended_syntax     => $rOpts->{'extended-syntax'},
 1153 
 1154                 continuation_indentation =>
 1155                   $rOpts->{'continuation-indentation'},
 1156                 outdent_labels => $rOpts->{'outdent-labels'},
 1157             );
 1158 
 1159             #---------------------------------------------------------------
 1160             # now we can do it
 1161             #---------------------------------------------------------------
 1162             process_this_file( $tokenizer, $formatter );
 1163 
 1164             #---------------------------------------------------------------
 1165             # close the input source and report errors
 1166             #---------------------------------------------------------------
 1167             $source_object->close_input_file();
 1168 
 1169             # line source for next iteration (if any) comes from the current
 1170             # temporary output buffer
 1171             if ( $iter < $max_iterations ) {
 1172 
 1173                 $sink_object->close_output_file();
 1174                 $source_object =
 1175                   Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts,
 1176                     $rpending_logfile_message );
 1177 
 1178                 # stop iterations if errors or converged
 1179                 #my $stop_now = $logger_object->{_warning_count};
 1180                 my $stop_now = $tokenizer->report_tokenization_errors();
 1181                 if ($stop_now) {
 1182                     $convergence_log_message = <<EOM;
 1183 Stopping iterations because of severe errors.                       
 1184 EOM
 1185                 }
 1186                 elsif ($do_convergence_test) {
 1187 
 1188                     my $digest = $md5_hex->($sink_buffer);
 1189                     if ( !$saw_md5{$digest} ) {
 1190                         $saw_md5{$digest} = $iter;
 1191                     }
 1192                     else {
 1193 
 1194                         # Deja vu, stop iterating
 1195                         $stop_now = 1;
 1196                         my $iterm = $iter - 1;
 1197                         if ( $saw_md5{$digest} != $iterm ) {
 1198 
 1199                             # Blinking (oscillating) between two stable
 1200                             # end states.  This has happened in the past
 1201                             # but at present there are no known instances.
 1202                             $convergence_log_message = <<EOM;
 1203 Blinking. Output for iteration $iter same as for $saw_md5{$digest}. 
 1204 EOM
 1205                             $diagnostics_object->write_diagnostics(
 1206                                 $convergence_log_message)
 1207                               if $diagnostics_object;
 1208                         }
 1209                         else {
 1210                             $convergence_log_message = <<EOM;
 1211 Converged.  Output for iteration $iter same as for iter $iterm.
 1212 EOM
 1213                             $diagnostics_object->write_diagnostics(
 1214                                 $convergence_log_message)
 1215                               if $diagnostics_object && $iterm > 2;
 1216                         }
 1217                     }
 1218                 } ## end if ($do_convergence_test)
 1219 
 1220                 if ($stop_now) {
 1221 
 1222                     # we are stopping the iterations early;
 1223                     # copy the output stream to its final destination
 1224                     $sink_object = $sink_object_final;
 1225                     while ( my $line = $source_object->get_line() ) {
 1226                         $sink_object->write_line($line);
 1227                     }
 1228                     $source_object->close_input_file();
 1229                     last;
 1230                 }
 1231             } ## end if ( $iter < $max_iterations)
 1232         }    # end loop over iterations for one source file
 1233 
 1234         # restore objects which have been temporarily undefined
 1235         # for second and higher iterations
 1236         $debugger_object = $debugger_object_final;
 1237         $logger_object   = $logger_object_final;
 1238 
 1239         $logger_object->write_logfile_entry($convergence_log_message)
 1240           if $convergence_log_message;
 1241 
 1242         #---------------------------------------------------------------
 1243         # Perform any postfilter operation
 1244         #---------------------------------------------------------------
 1245         if (   $postfilter
 1246             || $rOpts->{'assert-tidy'}
 1247             || $rOpts->{'assert-untidy'} )
 1248         {
 1249             $sink_object->close_output_file();
 1250             $sink_object =
 1251               Perl::Tidy::LineSink->new( $output_file, $tee_file,
 1252                 $line_separator, $rOpts, $rpending_logfile_message, $binmode );
 1253 
 1254             my $buf =
 1255                 $postfilter
 1256               ? $postfilter->($postfilter_buffer)
 1257               : $postfilter_buffer;
 1258 
 1259             # Check if file changed if requested, but only after any postfilter
 1260             if ( $rOpts->{'assert-tidy'} ) {
 1261                 my $digest_output = $md5_hex->($buf);
 1262                 if ( $digest_output ne $digest_input ) {
 1263                     $logger_object->warning(
 1264 "assertion failure: '--assert-tidy' is set but output differs from input\n"
 1265                     );
 1266                 }
 1267             }
 1268             if ( $rOpts->{'assert-untidy'} ) {
 1269                 my $digest_output = $md5_hex->($buf);
 1270                 if ( $digest_output eq $digest_input ) {
 1271                     $logger_object->warning(
 1272 "assertion failure: '--assert-untidy' is set but output equals input\n"
 1273                     );
 1274                 }
 1275             }
 1276 
 1277             $source_object =
 1278               Perl::Tidy::LineSource->new( \$buf, $rOpts,
 1279                 $rpending_logfile_message );
 1280             while ( my $line = $source_object->get_line() ) {
 1281                 $sink_object->write_line($line);
 1282             }
 1283             $source_object->close_input_file();
 1284         }
 1285 
 1286         # Save names of the input and output files for syntax check
 1287         my $ifname = $input_file;
 1288         my $ofname = $output_file;
 1289 
 1290         #---------------------------------------------------------------
 1291         # handle the -b option (backup and modify in-place)
 1292         #---------------------------------------------------------------
 1293         if ($in_place_modify) {
 1294             unless ( -f $input_file ) {
 1295 
 1296                 # oh, oh, no real file to backup ..
 1297                 # shouldn't happen because of numerous preliminary checks
 1298                 Die(
 1299 "problem with -b backing up input file '$input_file': not a file\n"
 1300                 );
 1301             }
 1302             my $backup_name = $input_file . $backup_extension;
 1303             if ( -f $backup_name ) {
 1304                 unlink($backup_name)
 1305                   or Die(
 1306 "unable to remove previous '$backup_name' for -b option; check permissions: $!\n"
 1307                   );
 1308             }
 1309 
 1310             # backup the input file
 1311             # we use copy for symlinks, move for regular files
 1312             if ( -l $input_file ) {
 1313                 File::Copy::copy( $input_file, $backup_name )
 1314                   or Die("File::Copy failed trying to backup source: $!");
 1315             }
 1316             else {
 1317                 rename( $input_file, $backup_name )
 1318                   or Die(
 1319 "problem renaming $input_file to $backup_name for -b option: $!\n"
 1320                   );
 1321             }
 1322             $ifname = $backup_name;
 1323 
 1324             # copy the output to the original input file
 1325             # NOTE: it would be nice to just close $output_file and use
 1326             # File::Copy::copy here, but in this case $output_file is the
 1327             # handle of an open nameless temporary file so we would lose
 1328             # everything if we closed it.
 1329             seek( $output_file, 0, 0 )
 1330               or Die("unable to rewind a temporary file for -b option: $!\n");
 1331             my $fout = IO::File->new("> $input_file")
 1332               or Die(
 1333 "problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n"
 1334               );
 1335             if ($binmode) {
 1336                 if (   $rOpts->{'character-encoding'}
 1337                     && $rOpts->{'character-encoding'} eq 'utf8' )
 1338                 {
 1339                     binmode $fout, ":raw:encoding(UTF-8)";
 1340                 }
 1341                 else { binmode $fout }
 1342             }
 1343             my $line;
 1344             while ( $line = $output_file->getline() ) {
 1345                 $fout->print($line);
 1346             }
 1347             $fout->close();
 1348             $output_file = $input_file;
 1349             $ofname      = $input_file;
 1350         }
 1351 
 1352         #---------------------------------------------------------------
 1353         # clean up and report errors
 1354         #---------------------------------------------------------------
 1355         $sink_object->close_output_file()    if $sink_object;
 1356         $debugger_object->close_debug_file() if $debugger_object;
 1357 
 1358         # set output file permissions
 1359         if ( $output_file && -f $output_file && !-l $output_file ) {
 1360             if (@input_file_stat) {
 1361 
 1362                 # Set file ownership and permissions
 1363                 if ( $rOpts->{'format'} eq 'tidy' ) {
 1364                     my ( $mode_i, $uid_i, $gid_i ) =
 1365                       @input_file_stat[ 2, 4, 5 ];
 1366                     my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ];
 1367                     my $input_file_permissions  = $mode_i & oct(7777);
 1368                     my $output_file_permissions = $input_file_permissions;
 1369 
 1370                     #rt128477: avoid inconsistent owner/group and suid/sgid
 1371                     if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
 1372 
 1373                # try to change owner and group to match input file if in -b mode
 1374                # note: chown returns number of files successfully changed
 1375                         if ( $in_place_modify
 1376                             && chown( $uid_i, $gid_i, $output_file ) )
 1377                         {
 1378                             # owner/group successfully changed
 1379                         }
 1380                         else {
 1381 
 1382                             # owner or group differ: do not copy suid and sgid
 1383                             $output_file_permissions = $mode_i & oct(777);
 1384                             if ( $input_file_permissions !=
 1385                                 $output_file_permissions )
 1386                             {
 1387                                 Warn(
 1388 "Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
 1389                                 );
 1390                             }
 1391                         }
 1392                     }
 1393 
 1394                     # Make the output file for rw unless we are in -b mode.
 1395                     # Explanation: perltidy does not unlink existing output
 1396                     # files before writing to them, for safety.  If a
 1397                     # designated output file exists and is not writable,
 1398                     # perltidy will halt.  This can prevent a data loss if a
 1399                     # user accidentally enters "perltidy infile -o
 1400                     # important_ro_file", or "perltidy infile -st
 1401                     # >important_ro_file". But it also means that perltidy can
 1402                     # get locked out of rerunning unless it marks its own
 1403                     # output files writable. The alternative, of always
 1404                     # unlinking the designated output file, is less safe and
 1405                     # not always possible, except in -b mode, where there is an
 1406                     # assumption that a previous backup can be unlinked even if
 1407                     # not writable.
 1408                     if ( !$in_place_modify ) {
 1409                         $output_file_permissions |= oct(600);
 1410                     }
 1411 
 1412                     if ( !chmod( $output_file_permissions, $output_file ) ) {
 1413 
 1414                         # couldn't change file permissions
 1415                         my $operm = sprintf "%04o", $output_file_permissions;
 1416                         Warn(
 1417 "Unable to set permissions for output file '$output_file' to $operm\n"
 1418                         );
 1419                     }
 1420                 }
 1421 
 1422                 # else use default permissions for html and any other format
 1423             }
 1424         }
 1425 
 1426         #---------------------------------------------------------------
 1427         # Do syntax check if requested and possible
 1428         #---------------------------------------------------------------
 1429         my $infile_syntax_ok = 0;    # -1 no  0=don't know   1 yes
 1430         if (   $logger_object
 1431             && $rOpts->{'check-syntax'}
 1432             && $ifname
 1433             && $ofname )
 1434         {
 1435             $infile_syntax_ok =
 1436               check_syntax( $ifname, $ofname, $logger_object, $rOpts );
 1437         }
 1438 
 1439         #---------------------------------------------------------------
 1440         # remove the original file for in-place modify as follows:
 1441         #   $delete_backup=0 never
 1442         #   $delete_backup=1 only if no errors
 1443         #   $delete_backup>1 always  : NOT ALLOWED, too risky, see above
 1444         #---------------------------------------------------------------
 1445         if (   $in_place_modify
 1446             && $delete_backup
 1447             && -f $ifname
 1448             && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) )
 1449         {
 1450 
 1451             # As an added safety precaution, do not delete the source file
 1452             # if its size has dropped from positive to zero, since this
 1453             # could indicate a disaster of some kind, including a hardware
 1454             # failure.  Actually, this could happen if you had a file of
 1455             # all comments (or pod) and deleted everything with -dac (-dap)
 1456             # for some reason.
 1457             if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) {
 1458                 Warn(
 1459 "output file '$output_file' missing or zero length; original '$ifname' not deleted\n"
 1460                 );
 1461             }
 1462             else {
 1463                 unlink($ifname)
 1464                   or Die(
 1465 "unable to remove previous '$ifname' for -b option; check permissions: $!\n"
 1466                   );
 1467             }
 1468         }
 1469 
 1470         $logger_object->finish( $infile_syntax_ok, $formatter )
 1471           if $logger_object;
 1472     }    # end of main loop to process all files
 1473 
 1474     # Fix for RT #130297: return a true value if anything was written to the
 1475     # standard error output, even non-fatal warning messages, otherwise return
 1476     # false.
 1477 
 1478     # These exit codes are returned:
 1479     #  0 = perltidy ran to completion with no errors
 1480     #  1 = perltidy could not run to completion due to errors
 1481     #  2 = perltidy ran to completion with error messages
 1482 
 1483     # Note that if perltidy is run with multiple files, any single file with
 1484     # errors or warnings will write a line like
 1485     #        '## Please see file testing.t.ERR'
 1486     # to standard output for each file with errors, so the flag will be true,
 1487     # even only some of the multiple files may have had errors.
 1488 
 1489   NORMAL_EXIT:
 1490     my $ret = $Warn_count ? 2 : 0;
 1491     return $ret;
 1492 
 1493   ERROR_EXIT:
 1494     return 1;
 1495 }    # end of main program perltidy
 1496 
 1497 sub get_stream_as_named_file {
 1498 
 1499     # Return the name of a file containing a stream of data, creating
 1500     # a temporary file if necessary.
 1501     # Given:
 1502     #  $stream - the name of a file or stream
 1503     # Returns:
 1504     #  $fname = name of file if possible, or undef
 1505     #  $if_tmpfile = true if temp file, undef if not temp file
 1506     #
 1507     # This routine is needed for passing actual files to Perl for
 1508     # a syntax check.
 1509     my ($stream) = @_;
 1510     my $is_tmpfile;
 1511     my $fname;
 1512     if ($stream) {
 1513         if ( ref($stream) ) {
 1514             my ( $fh_stream, $fh_name ) =
 1515               Perl::Tidy::streamhandle( $stream, 'r' );
 1516             if ($fh_stream) {
 1517                 my ( $fout, $tmpnam ) = File::Temp::tempfile();
 1518                 if ($fout) {
 1519                     $fname      = $tmpnam;
 1520                     $is_tmpfile = 1;
 1521                     binmode $fout;
 1522                     while ( my $line = $fh_stream->getline() ) {
 1523                         $fout->print($line);
 1524                     }
 1525                     $fout->close();
 1526                 }
 1527                 $fh_stream->close();
 1528             }
 1529         }
 1530         elsif ( $stream ne '-' && -f $stream ) {
 1531             $fname = $stream;
 1532         }
 1533     }
 1534     return ( $fname, $is_tmpfile );
 1535 }
 1536 
 1537 sub fileglob_to_re {
 1538 
 1539     # modified (corrected) from version in find2perl
 1540     my $x = shift;
 1541     $x =~ s#([./^\$()])#\\$1#g;    # escape special characters
 1542     $x =~ s#\*#.*#g;               # '*' -> '.*'
 1543     $x =~ s#\?#.#g;                # '?' -> '.'
 1544     return "^$x\\z";               # match whole word
 1545 }
 1546 
 1547 sub make_extension {
 1548 
 1549     # Make a file extension, including any leading '.' if necessary
 1550     # The '.' may actually be an '_' under VMS
 1551     my ( $extension, $default, $dot ) = @_;
 1552 
 1553     # Use the default if none specified
 1554     $extension = $default unless ($extension);
 1555 
 1556     # Only extensions with these leading characters get a '.'
 1557     # This rule gives the user some freedom
 1558     if ( $extension =~ /^[a-zA-Z0-9]/ ) {
 1559         $extension = $dot . $extension;
 1560     }
 1561     return $extension;
 1562 }
 1563 
 1564 sub write_logfile_header {
 1565     my (
 1566         $rOpts,        $logger_object, $config_file,
 1567         $rraw_options, $Windows_type,  $readable_options
 1568     ) = @_;
 1569     $logger_object->write_logfile_entry(
 1570 "perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
 1571     );
 1572     if ($Windows_type) {
 1573         $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
 1574     }
 1575     my $options_string = join( ' ', @{$rraw_options} );
 1576 
 1577     if ($config_file) {
 1578         $logger_object->write_logfile_entry(
 1579             "Found Configuration File >>> $config_file \n");
 1580     }
 1581     $logger_object->write_logfile_entry(
 1582         "Configuration and command line parameters for this run:\n");
 1583     $logger_object->write_logfile_entry("$options_string\n");
 1584 
 1585     if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
 1586         $rOpts->{'logfile'} = 1;    # force logfile to be saved
 1587         $logger_object->write_logfile_entry(
 1588             "Final parameter set for this run\n");
 1589         $logger_object->write_logfile_entry(
 1590             "------------------------------------\n");
 1591 
 1592         $logger_object->write_logfile_entry($readable_options);
 1593 
 1594         $logger_object->write_logfile_entry(
 1595             "------------------------------------\n");
 1596     }
 1597     $logger_object->write_logfile_entry(
 1598         "To find error messages search for 'WARNING' with your editor\n");
 1599     return;
 1600 }
 1601 
 1602 sub generate_options {
 1603 
 1604     ######################################################################
 1605     # Generate and return references to:
 1606     #  @option_string - the list of options to be passed to Getopt::Long
 1607     #  @defaults - the list of default options
 1608     #  %expansion - a hash showing how all abbreviations are expanded
 1609     #  %category - a hash giving the general category of each option
 1610     #  %option_range - a hash giving the valid ranges of certain options
 1611 
 1612     # Note: a few options are not documented in the man page and usage
 1613     # message. This is because these are experimental or debug options and
 1614     # may or may not be retained in future versions.
 1615     #
 1616     # Here are the undocumented flags as far as I know.  Any of them
 1617     # may disappear at any time.  They are mainly for fine-tuning
 1618     # and debugging.
 1619     #
 1620     # fll --> fuzzy-line-length           # a trivial parameter which gets
 1621     #                                       turned off for the extrude option
 1622     #                                       which is mainly for debugging
 1623     # scl --> short-concatenation-item-length   # helps break at '.'
 1624     # recombine                           # for debugging line breaks
 1625     # valign                              # for debugging vertical alignment
 1626     # I   --> DIAGNOSTICS                 # for debugging [**DEACTIVATED**]
 1627     ######################################################################
 1628 
 1629     # here is a summary of the Getopt codes:
 1630     # <none> does not take an argument
 1631     # =s takes a mandatory string
 1632     # :s takes an optional string  (DO NOT USE - filenames will get eaten up)
 1633     # =i takes a mandatory integer
 1634     # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
 1635     # ! does not take an argument and may be negated
 1636     #  i.e., -foo and -nofoo are allowed
 1637     # a double dash signals the end of the options list
 1638     #
 1639     #---------------------------------------------------------------
 1640     # Define the option string passed to GetOptions.
 1641     #---------------------------------------------------------------
 1642 
 1643     my @option_string   = ();
 1644     my %expansion       = ();
 1645     my %option_category = ();
 1646     my %option_range    = ();
 1647     my $rexpansion      = \%expansion;
 1648 
 1649     # names of categories in manual
 1650     # leading integers will allow sorting
 1651     my @category_name = (
 1652         '0. I/O control',
 1653         '1. Basic formatting options',
 1654         '2. Code indentation control',
 1655         '3. Whitespace control',
 1656         '4. Comment controls',
 1657         '5. Linebreak controls',
 1658         '6. Controlling list formatting',
 1659         '7. Retaining or ignoring existing line breaks',
 1660         '8. Blank line control',
 1661         '9. Other controls',
 1662         '10. HTML options',
 1663         '11. pod2html options',
 1664         '12. Controlling HTML properties',
 1665         '13. Debugging',
 1666     );
 1667 
 1668     #  These options are parsed directly by perltidy:
 1669     #    help h
 1670     #    version v
 1671     #  However, they are included in the option set so that they will
 1672     #  be seen in the options dump.
 1673 
 1674     # These long option names have no abbreviations or are treated specially
 1675     @option_string = qw(
 1676       html!
 1677       noprofile
 1678       no-profile
 1679       npro
 1680       recombine!
 1681       valign!
 1682       notidy
 1683     );
 1684 
 1685     my $category = 13;    # Debugging
 1686     foreach (@option_string) {
 1687         my $opt = $_;     # must avoid changing the actual flag
 1688         $opt =~ s/!$//;
 1689         $option_category{$opt} = $category_name[$category];
 1690     }
 1691 
 1692     $category = 11;                                       # HTML
 1693     $option_category{html} = $category_name[$category];
 1694 
 1695     # routine to install and check options
 1696     my $add_option = sub {
 1697         my ( $long_name, $short_name, $flag ) = @_;
 1698         push @option_string, $long_name . $flag;
 1699         $option_category{$long_name} = $category_name[$category];
 1700         if ($short_name) {
 1701             if ( $expansion{$short_name} ) {
 1702                 my $existing_name = $expansion{$short_name}[0];
 1703                 Die(
 1704 "redefining abbreviation $short_name for $long_name; already used for $existing_name\n"
 1705                 );
 1706             }
 1707             $expansion{$short_name} = [$long_name];
 1708             if ( $flag eq '!' ) {
 1709                 my $nshort_name = 'n' . $short_name;
 1710                 my $nolong_name = 'no' . $long_name;
 1711                 if ( $expansion{$nshort_name} ) {
 1712                     my $existing_name = $expansion{$nshort_name}[0];
 1713                     Die(
 1714 "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n"
 1715                     );
 1716                 }
 1717                 $expansion{$nshort_name} = [$nolong_name];
 1718             }
 1719         }
 1720     };
 1721 
 1722     # Install long option names which have a simple abbreviation.
 1723     # Options with code '!' get standard negation ('no' for long names,
 1724     # 'n' for abbreviations).  Categories follow the manual.
 1725 
 1726     ###########################
 1727     $category = 0;    # I/O_Control
 1728     ###########################
 1729     $add_option->( 'backup-and-modify-in-place', 'b',     '!' );
 1730     $add_option->( 'backup-file-extension',      'bext',  '=s' );
 1731     $add_option->( 'force-read-binary',          'f',     '!' );
 1732     $add_option->( 'format',                     'fmt',   '=s' );
 1733     $add_option->( 'iterations',                 'it',    '=i' );
 1734     $add_option->( 'logfile',                    'log',   '!' );
 1735     $add_option->( 'logfile-gap',                'g',     ':i' );
 1736     $add_option->( 'outfile',                    'o',     '=s' );
 1737     $add_option->( 'output-file-extension',      'oext',  '=s' );
 1738     $add_option->( 'output-path',                'opath', '=s' );
 1739     $add_option->( 'profile',                    'pro',   '=s' );
 1740     $add_option->( 'quiet',                      'q',     '!' );
 1741     $add_option->( 'standard-error-output',      'se',    '!' );
 1742     $add_option->( 'standard-output',            'st',    '!' );
 1743     $add_option->( 'warning-output',             'w',     '!' );
 1744     $add_option->( 'character-encoding',         'enc',   '=s' );
 1745 
 1746     # options which are both toggle switches and values moved here
 1747     # to hide from tidyview (which does not show category 0 flags):
 1748     # -ole moved here from category 1
 1749     # -sil moved here from category 2
 1750     $add_option->( 'output-line-ending',         'ole', '=s' );
 1751     $add_option->( 'starting-indentation-level', 'sil', '=i' );
 1752 
 1753     ########################################
 1754     $category = 1;    # Basic formatting options
 1755     ########################################
 1756     $add_option->( 'check-syntax',                 'syn',  '!' );
 1757     $add_option->( 'entab-leading-whitespace',     'et',   '=i' );
 1758     $add_option->( 'indent-columns',               'i',    '=i' );
 1759     $add_option->( 'maximum-line-length',          'l',    '=i' );
 1760     $add_option->( 'variable-maximum-line-length', 'vmll', '!' );
 1761     $add_option->( 'whitespace-cycle',             'wc',   '=i' );
 1762     $add_option->( 'perl-syntax-check-flags',      'pscf', '=s' );
 1763     $add_option->( 'preserve-line-endings',        'ple',  '!' );
 1764     $add_option->( 'tabs',                         't',    '!' );
 1765     $add_option->( 'default-tabsize',              'dt',   '=i' );
 1766     $add_option->( 'extended-syntax',              'xs',   '!' );
 1767     $add_option->( 'assert-tidy',                  'ast',  '!' );
 1768     $add_option->( 'assert-untidy',                'asu',  '!' );
 1769 
 1770     ########################################
 1771     $category = 2;    # Code indentation control
 1772     ########################################
 1773     $add_option->( 'continuation-indentation',           'ci',   '=i' );
 1774     $add_option->( 'line-up-parentheses',                'lp',   '!' );
 1775     $add_option->( 'outdent-keyword-list',               'okwl', '=s' );
 1776     $add_option->( 'outdent-keywords',                   'okw',  '!' );
 1777     $add_option->( 'outdent-labels',                     'ola',  '!' );
 1778     $add_option->( 'outdent-long-quotes',                'olq',  '!' );
 1779     $add_option->( 'indent-closing-brace',               'icb',  '!' );
 1780     $add_option->( 'closing-token-indentation',          'cti',  '=i' );
 1781     $add_option->( 'closing-paren-indentation',          'cpi',  '=i' );
 1782     $add_option->( 'closing-brace-indentation',          'cbi',  '=i' );
 1783     $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' );
 1784     $add_option->( 'brace-left-and-indent',              'bli',  '!' );
 1785     $add_option->( 'brace-left-and-indent-list',         'blil', '=s' );
 1786 
 1787     ########################################
 1788     $category = 3;    # Whitespace control
 1789     ########################################
 1790     $add_option->( 'add-semicolons',                            'asc',   '!' );
 1791     $add_option->( 'add-whitespace',                            'aws',   '!' );
 1792     $add_option->( 'block-brace-tightness',                     'bbt',   '=i' );
 1793     $add_option->( 'brace-tightness',                           'bt',    '=i' );
 1794     $add_option->( 'delete-old-whitespace',                     'dws',   '!' );
 1795     $add_option->( 'delete-semicolons',                         'dsm',   '!' );
 1796     $add_option->( 'nospace-after-keyword',                     'nsak',  '=s' );
 1797     $add_option->( 'nowant-left-space',                         'nwls',  '=s' );
 1798     $add_option->( 'nowant-right-space',                        'nwrs',  '=s' );
 1799     $add_option->( 'paren-tightness',                           'pt',    '=i' );
 1800     $add_option->( 'space-after-keyword',                       'sak',   '=s' );
 1801     $add_option->( 'space-for-semicolon',                       'sfs',   '!' );
 1802     $add_option->( 'space-function-paren',                      'sfp',   '!' );
 1803     $add_option->( 'space-keyword-paren',                       'skp',   '!' );
 1804     $add_option->( 'space-terminal-semicolon',                  'sts',   '!' );
 1805     $add_option->( 'square-bracket-tightness',                  'sbt',   '=i' );
 1806     $add_option->( 'square-bracket-vertical-tightness',         'sbvt',  '=i' );
 1807     $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
 1808     $add_option->( 'tight-secret-operators',                    'tso',   '!' );
 1809     $add_option->( 'trim-qw',                                   'tqw',   '!' );
 1810     $add_option->( 'trim-pod',                                  'trp',   '!' );
 1811     $add_option->( 'want-left-space',                           'wls',   '=s' );
 1812     $add_option->( 'want-right-space',                          'wrs',   '=s' );
 1813 
 1814     ########################################
 1815     $category = 4;    # Comment controls
 1816     ########################################
 1817     $add_option->( 'closing-side-comment-else-flag',    'csce', '=i' );
 1818     $add_option->( 'closing-side-comment-interval',     'csci', '=i' );
 1819     $add_option->( 'closing-side-comment-list',         'cscl', '=s' );
 1820     $add_option->( 'closing-side-comment-maximum-text', 'csct', '=i' );
 1821     $add_option->( 'closing-side-comment-prefix',       'cscp', '=s' );
 1822     $add_option->( 'closing-side-comment-warnings',     'cscw', '!' );
 1823     $add_option->( 'closing-side-comments',             'csc',  '!' );
 1824     $add_option->( 'closing-side-comments-balanced',    'cscb', '!' );
 1825     $add_option->( 'format-skipping',                   'fs',   '!' );
 1826     $add_option->( 'format-skipping-begin',             'fsb',  '=s' );
 1827     $add_option->( 'format-skipping-end',               'fse',  '=s' );
 1828     $add_option->( 'hanging-side-comments',             'hsc',  '!' );
 1829     $add_option->( 'indent-block-comments',             'ibc',  '!' );
 1830     $add_option->( 'indent-spaced-block-comments',      'isbc', '!' );
 1831     $add_option->( 'fixed-position-side-comment',       'fpsc', '=i' );
 1832     $add_option->( 'minimum-space-to-comment',          'msc',  '=i' );
 1833     $add_option->( 'outdent-long-comments',             'olc',  '!' );
 1834     $add_option->( 'outdent-static-block-comments',     'osbc', '!' );
 1835     $add_option->( 'static-block-comment-prefix',       'sbcp', '=s' );
 1836     $add_option->( 'static-block-comments',             'sbc',  '!' );
 1837     $add_option->( 'static-side-comment-prefix',        'sscp', '=s' );
 1838     $add_option->( 'static-side-comments',              'ssc',  '!' );
 1839     $add_option->( 'ignore-side-comment-lengths',       'iscl', '!' );
 1840 
 1841     ########################################
 1842     $category = 5;    # Linebreak controls
 1843     ########################################
 1844     $add_option->( 'add-newlines',                            'anl',   '!' );
 1845     $add_option->( 'block-brace-vertical-tightness',          'bbvt',  '=i' );
 1846     $add_option->( 'block-brace-vertical-tightness-list',     'bbvtl', '=s' );
 1847     $add_option->( 'brace-vertical-tightness',                'bvt',   '=i' );
 1848     $add_option->( 'brace-vertical-tightness-closing',        'bvtc',  '=i' );
 1849     $add_option->( 'cuddled-else',                            'ce',    '!' );
 1850     $add_option->( 'cuddled-block-list',                      'cbl',   '=s' );
 1851     $add_option->( 'cuddled-block-list-exclusive',            'cblx',  '!' );
 1852     $add_option->( 'cuddled-break-option',                    'cbo',   '=i' );
 1853     $add_option->( 'delete-old-newlines',                     'dnl',   '!' );
 1854     $add_option->( 'opening-brace-always-on-right',           'bar',   '!' );
 1855     $add_option->( 'opening-brace-on-new-line',               'bl',    '!' );
 1856     $add_option->( 'opening-hash-brace-right',                'ohbr',  '!' );
 1857     $add_option->( 'opening-paren-right',                     'opr',   '!' );
 1858     $add_option->( 'opening-square-bracket-right',            'osbr',  '!' );
 1859     $add_option->( 'opening-anonymous-sub-brace-on-new-line', 'asbl',  '!' );
 1860     $add_option->( 'opening-sub-brace-on-new-line',           'sbl',   '!' );
 1861     $add_option->( 'paren-vertical-tightness',                'pvt',   '=i' );
 1862     $add_option->( 'paren-vertical-tightness-closing',        'pvtc',  '=i' );
 1863     $add_option->( 'weld-nested-containers',                  'wn',    '!' );
 1864     $add_option->( 'space-backslash-quote',                   'sbq',   '=i' );
 1865     $add_option->( 'stack-closing-block-brace',               'scbb',  '!' );
 1866     $add_option->( 'stack-closing-hash-brace',                'schb',  '!' );
 1867     $add_option->( 'stack-closing-paren',                     'scp',   '!' );
 1868     $add_option->( 'stack-closing-square-bracket',            'scsb',  '!' );
 1869     $add_option->( 'stack-opening-block-brace',               'sobb',  '!' );
 1870     $add_option->( 'stack-opening-hash-brace',                'sohb',  '!' );
 1871     $add_option->( 'stack-opening-paren',                     'sop',   '!' );
 1872     $add_option->( 'stack-opening-square-bracket',            'sosb',  '!' );
 1873     $add_option->( 'vertical-tightness',                      'vt',    '=i' );
 1874     $add_option->( 'vertical-tightness-closing',              'vtc',   '=i' );
 1875     $add_option->( 'want-break-after',                        'wba',   '=s' );
 1876     $add_option->( 'want-break-before',                       'wbb',   '=s' );
 1877     $add_option->( 'break-after-all-operators',               'baao',  '!' );
 1878     $add_option->( 'break-before-all-operators',              'bbao',  '!' );
 1879     $add_option->( 'keep-interior-semicolons',                'kis',   '!' );
 1880     $add_option->( 'one-line-block-semicolons',               'olbs',  '=i' );
 1881 
 1882     ########################################
 1883     $category = 6;    # Controlling list formatting
 1884     ########################################
 1885     $add_option->( 'break-at-old-comma-breakpoints', 'boc', '!' );
 1886     $add_option->( 'comma-arrow-breakpoints',        'cab', '=i' );
 1887     $add_option->( 'maximum-fields-per-table',       'mft', '=i' );
 1888 
 1889     ########################################
 1890     $category = 7;    # Retaining or ignoring existing line breaks
 1891     ########################################
 1892     $add_option->( 'break-at-old-keyword-breakpoints',   'bok', '!' );
 1893     $add_option->( 'break-at-old-logical-breakpoints',   'bol', '!' );
 1894     $add_option->( 'break-at-old-method-breakpoints',    'bom', '!' );
 1895     $add_option->( 'break-at-old-ternary-breakpoints',   'bot', '!' );
 1896     $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' );
 1897     $add_option->( 'ignore-old-breakpoints',             'iob', '!' );
 1898 
 1899     ########################################
 1900     $category = 8;    # Blank line control
 1901     ########################################
 1902     $add_option->( 'blanks-before-blocks',            'bbb',  '!' );
 1903     $add_option->( 'blanks-before-comments',          'bbc',  '!' );
 1904     $add_option->( 'blank-lines-before-subs',         'blbs', '=i' );
 1905     $add_option->( 'blank-lines-before-packages',     'blbp', '=i' );
 1906     $add_option->( 'long-block-line-count',           'lbl',  '=i' );
 1907     $add_option->( 'maximum-consecutive-blank-lines', 'mbl',  '=i' );
 1908     $add_option->( 'keep-old-blank-lines',            'kbl',  '=i' );
 1909 
 1910     $add_option->( 'keyword-group-blanks-list',         'kgbl', '=s' );
 1911     $add_option->( 'keyword-group-blanks-size',         'kgbs', '=s' );
 1912     $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
 1913     $add_option->( 'keyword-group-blanks-before',       'kgbb', '=i' );
 1914     $add_option->( 'keyword-group-blanks-after',        'kgba', '=i' );
 1915     $add_option->( 'keyword-group-blanks-inside',       'kgbi', '!' );
 1916     $add_option->( 'keyword-group-blanks-delete',       'kgbd', '!' );
 1917 
 1918     $add_option->( 'blank-lines-after-opening-block',       'blao',  '=i' );
 1919     $add_option->( 'blank-lines-before-closing-block',      'blbc',  '=i' );
 1920     $add_option->( 'blank-lines-after-opening-block-list',  'blaol', '=s' );
 1921     $add_option->( 'blank-lines-before-closing-block-list', 'blbcl', '=s' );
 1922 
 1923     ########################################
 1924     $category = 9;    # Other controls
 1925     ########################################
 1926     $add_option->( 'delete-block-comments',        'dbc',  '!' );
 1927     $add_option->( 'delete-closing-side-comments', 'dcsc', '!' );
 1928     $add_option->( 'delete-pod',                   'dp',   '!' );
 1929     $add_option->( 'delete-side-comments',         'dsc',  '!' );
 1930     $add_option->( 'tee-block-comments',           'tbc',  '!' );
 1931     $add_option->( 'tee-pod',                      'tp',   '!' );
 1932     $add_option->( 'tee-side-comments',            'tsc',  '!' );
 1933     $add_option->( 'look-for-autoloader',          'lal',  '!' );
 1934     $add_option->( 'look-for-hash-bang',           'x',    '!' );
 1935     $add_option->( 'look-for-selfloader',          'lsl',  '!' );
 1936     $add_option->( 'pass-version-line',            'pvl',  '!' );
 1937 
 1938     ########################################
 1939     $category = 13;    # Debugging
 1940     ########################################
 1941 ##  $add_option->( 'DIAGNOSTICS',                     'I',    '!' );
 1942     $add_option->( 'DEBUG',                           'D',    '!' );
 1943     $add_option->( 'dump-cuddled-block-list',         'dcbl', '!' );
 1944     $add_option->( 'dump-defaults',                   'ddf',  '!' );
 1945     $add_option->( 'dump-long-names',                 'dln',  '!' );
 1946     $add_option->( 'dump-options',                    'dop',  '!' );
 1947     $add_option->( 'dump-profile',                    'dpro', '!' );
 1948     $add_option->( 'dump-short-names',                'dsn',  '!' );
 1949     $add_option->( 'dump-token-types',                'dtt',  '!' );
 1950     $add_option->( 'dump-want-left-space',            'dwls', '!' );
 1951     $add_option->( 'dump-want-right-space',           'dwrs', '!' );
 1952     $add_option->( 'fuzzy-line-length',               'fll',  '!' );
 1953     $add_option->( 'help',                            'h',    '' );
 1954     $add_option->( 'short-concatenation-item-length', 'scl',  '=i' );
 1955     $add_option->( 'show-options',                    'opt',  '!' );
 1956     $add_option->( 'timestamp',                       'ts',   '!' );
 1957     $add_option->( 'version',                         'v',    '' );
 1958     $add_option->( 'memoize',                         'mem',  '!' );
 1959     $add_option->( 'file-size-order',                 'fso',  '!' );
 1960 
 1961     #---------------------------------------------------------------------
 1962 
 1963     # The Perl::Tidy::HtmlWriter will add its own options to the string
 1964     Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
 1965 
 1966     ########################################
 1967     # Set categories 10, 11, 12
 1968     ########################################
 1969     # Based on their known order
 1970     $category = 12;    # HTML properties
 1971     foreach my $opt (@option_string) {
 1972         my $long_name = $opt;
 1973         $long_name =~ s/(!|=.*|:.*)$//;
 1974         unless ( defined( $option_category{$long_name} ) ) {
 1975             if ( $long_name =~ /^html-linked/ ) {
 1976                 $category = 10;    # HTML options
 1977             }
 1978             elsif ( $long_name =~ /^pod2html/ ) {
 1979                 $category = 11;    # Pod2html
 1980             }
 1981             $option_category{$long_name} = $category_name[$category];
 1982         }
 1983     }
 1984 
 1985     #---------------------------------------------------------------
 1986     # Assign valid ranges to certain options
 1987     #---------------------------------------------------------------
 1988     # In the future, these may be used to make preliminary checks
 1989     # hash keys are long names
 1990     # If key or value is undefined:
 1991     #   strings may have any value
 1992     #   integer ranges are >=0
 1993     # If value is defined:
 1994     #   value is [qw(any valid words)] for strings
 1995     #   value is [min, max] for integers
 1996     #   if min is undefined, there is no lower limit
 1997     #   if max is undefined, there is no upper limit
 1998     # Parameters not listed here have defaults
 1999     %option_range = (
 2000         'format'             => [ 'tidy', 'html', 'user' ],
 2001         'output-line-ending' => [ 'dos',  'win',  'mac', 'unix' ],
 2002         'character-encoding' => [ 'none', 'utf8' ],
 2003 
 2004         'space-backslash-quote' => [ 0, 2 ],
 2005 
 2006         'block-brace-tightness'    => [ 0, 2 ],
 2007         'brace-tightness'          => [ 0, 2 ],
 2008         'paren-tightness'          => [ 0, 2 ],
 2009         'square-bracket-tightness' => [ 0, 2 ],
 2010 
 2011         'block-brace-vertical-tightness'            => [ 0, 2 ],
 2012         'brace-vertical-tightness'                  => [ 0, 2 ],
 2013         'brace-vertical-tightness-closing'          => [ 0, 2 ],
 2014         'paren-vertical-tightness'                  => [ 0, 2 ],
 2015         'paren-vertical-tightness-closing'          => [ 0, 2 ],
 2016         'square-bracket-vertical-tightness'         => [ 0, 2 ],
 2017         'square-bracket-vertical-tightness-closing' => [ 0, 2 ],
 2018         'vertical-tightness'                        => [ 0, 2 ],
 2019         'vertical-tightness-closing'                => [ 0, 2 ],
 2020 
 2021         'closing-brace-indentation'          => [ 0, 3 ],
 2022         'closing-paren-indentation'          => [ 0, 3 ],
 2023         'closing-square-bracket-indentation' => [ 0, 3 ],
 2024         'closing-token-indentation'          => [ 0, 3 ],
 2025 
 2026         'closing-side-comment-else-flag' => [ 0, 2 ],
 2027         'comma-arrow-breakpoints'        => [ 0, 5 ],
 2028 
 2029         'keyword-group-blanks-before' => [ 0, 2 ],
 2030         'keyword-group-blanks-after'  => [ 0, 2 ],
 2031     );
 2032 
 2033     # Note: we could actually allow negative ci if someone really wants it:
 2034     # $option_range{'continuation-indentation'} = [ undef, undef ];
 2035 
 2036     #---------------------------------------------------------------
 2037     # Assign default values to the above options here, except
 2038     # for 'outfile' and 'help'.
 2039     # These settings should approximate the perlstyle(1) suggestions.
 2040     #---------------------------------------------------------------
 2041     my @defaults = qw(
 2042       add-newlines
 2043       add-semicolons
 2044       add-whitespace
 2045       blanks-before-blocks
 2046       blanks-before-comments
 2047       blank-lines-before-subs=1
 2048       blank-lines-before-packages=1
 2049 
 2050       keyword-group-blanks-size=5
 2051       keyword-group-blanks-repeat-count=0
 2052       keyword-group-blanks-before=1
 2053       keyword-group-blanks-after=1
 2054       nokeyword-group-blanks-inside
 2055       nokeyword-group-blanks-delete
 2056 
 2057       block-brace-tightness=0
 2058       block-brace-vertical-tightness=0
 2059       brace-tightness=1
 2060       brace-vertical-tightness-closing=0
 2061       brace-vertical-tightness=0
 2062       break-at-old-logical-breakpoints
 2063       break-at-old-ternary-breakpoints
 2064       break-at-old-attribute-breakpoints
 2065       break-at-old-keyword-breakpoints
 2066       comma-arrow-breakpoints=5
 2067       nocheck-syntax
 2068       closing-side-comment-interval=6
 2069       closing-side-comment-maximum-text=20
 2070       closing-side-comment-else-flag=0
 2071       closing-side-comments-balanced
 2072       closing-paren-indentation=0
 2073       closing-brace-indentation=0
 2074       closing-square-bracket-indentation=0
 2075       continuation-indentation=2
 2076       cuddled-break-option=1
 2077       delete-old-newlines
 2078       delete-semicolons
 2079       extended-syntax
 2080       fuzzy-line-length
 2081       hanging-side-comments
 2082       indent-block-comments
 2083       indent-columns=4
 2084       iterations=1
 2085       keep-old-blank-lines=1
 2086       long-block-line-count=8
 2087       look-for-autoloader
 2088       look-for-selfloader
 2089       maximum-consecutive-blank-lines=1
 2090       maximum-fields-per-table=0
 2091       maximum-line-length=80
 2092       memoize
 2093       minimum-space-to-comment=4
 2094       nobrace-left-and-indent
 2095       nocuddled-else
 2096       nodelete-old-whitespace
 2097       nohtml
 2098       nologfile
 2099       noquiet
 2100       noshow-options
 2101       nostatic-side-comments
 2102       notabs
 2103       nowarning-output
 2104       character-encoding=none
 2105       one-line-block-semicolons=1
 2106       outdent-labels
 2107       outdent-long-quotes
 2108       outdent-long-comments
 2109       paren-tightness=1
 2110       paren-vertical-tightness-closing=0
 2111       paren-vertical-tightness=0
 2112       pass-version-line
 2113       noweld-nested-containers
 2114       recombine
 2115       valign
 2116       short-concatenation-item-length=8
 2117       space-for-semicolon
 2118       space-backslash-quote=1
 2119       square-bracket-tightness=1
 2120       square-bracket-vertical-tightness-closing=0
 2121       square-bracket-vertical-tightness=0
 2122       static-block-comments
 2123       timestamp
 2124       trim-qw
 2125       format=tidy
 2126       backup-file-extension=bak
 2127       format-skipping
 2128       default-tabsize=8
 2129 
 2130       pod2html
 2131       html-table-of-contents
 2132       html-entities
 2133     );
 2134 
 2135     push @defaults, "perl-syntax-check-flags=-c -T";
 2136 
 2137     #---------------------------------------------------------------
 2138     # Define abbreviations which will be expanded into the above primitives.
 2139     # These may be defined recursively.
 2140     #---------------------------------------------------------------
 2141     %expansion = (
 2142         %expansion,
 2143         'freeze-newlines'   => [qw(noadd-newlines nodelete-old-newlines)],
 2144         'fnl'               => [qw(freeze-newlines)],
 2145         'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)],
 2146         'fws'               => [qw(freeze-whitespace)],
 2147         'freeze-blank-lines' =>
 2148           [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)],
 2149         'fbl'                => [qw(freeze-blank-lines)],
 2150         'indent-only'        => [qw(freeze-newlines freeze-whitespace)],
 2151         'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
 2152         'nooutdent-long-lines' =>
 2153           [qw(nooutdent-long-quotes nooutdent-long-comments)],
 2154         'noll' => [qw(nooutdent-long-lines)],
 2155         'io'   => [qw(indent-only)],
 2156         'delete-all-comments' =>
 2157           [qw(delete-block-comments delete-side-comments delete-pod)],
 2158         'nodelete-all-comments' =>
 2159           [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
 2160         'dac'  => [qw(delete-all-comments)],
 2161         'ndac' => [qw(nodelete-all-comments)],
 2162         'gnu'  => [qw(gnu-style)],
 2163         'pbp'  => [qw(perl-best-practices)],
 2164         'tee-all-comments' =>
 2165           [qw(tee-block-comments tee-side-comments tee-pod)],
 2166         'notee-all-comments' =>
 2167           [qw(notee-block-comments notee-side-comments notee-pod)],
 2168         'tac'   => [qw(tee-all-comments)],
 2169         'ntac'  => [qw(notee-all-comments)],
 2170         'html'  => [qw(format=html)],
 2171         'nhtml' => [qw(format=tidy)],
 2172         'tidy'  => [qw(format=tidy)],
 2173 
 2174         # -cb is now a synonym for -ce
 2175         'cb'             => [qw(cuddled-else)],
 2176         'cuddled-blocks' => [qw(cuddled-else)],
 2177 
 2178         'utf8' => [qw(character-encoding=utf8)],
 2179         'UTF8' => [qw(character-encoding=utf8)],
 2180 
 2181         'swallow-optional-blank-lines'   => [qw(kbl=0)],
 2182         'noswallow-optional-blank-lines' => [qw(kbl=1)],
 2183         'sob'                            => [qw(kbl=0)],
 2184         'nsob'                           => [qw(kbl=1)],
 2185 
 2186         'break-after-comma-arrows'   => [qw(cab=0)],
 2187         'nobreak-after-comma-arrows' => [qw(cab=1)],
 2188         'baa'                        => [qw(cab=0)],
 2189         'nbaa'                       => [qw(cab=1)],
 2190 
 2191         'blanks-before-subs'   => [qw(blbs=1 blbp=1)],
 2192         'bbs'                  => [qw(blbs=1 blbp=1)],
 2193         'noblanks-before-subs' => [qw(blbs=0 blbp=0)],
 2194         'nbbs'                 => [qw(blbs=0 blbp=0)],
 2195 
 2196         'keyword-group-blanks'   => [qw(kgbb=2 kgbi kgba=2)],
 2197         'kgb'                    => [qw(kgbb=2 kgbi kgba=2)],
 2198         'nokeyword-group-blanks' => [qw(kgbb=1 nkgbi kgba=1)],
 2199         'nkgb'                   => [qw(kgbb=1 nkgbi kgba=1)],
 2200 
 2201         'break-at-old-trinary-breakpoints' => [qw(bot)],
 2202 
 2203         'cti=0' => [qw(cpi=0 cbi=0 csbi=0)],
 2204         'cti=1' => [qw(cpi=1 cbi=1 csbi=1)],
 2205         'cti=2' => [qw(cpi=2 cbi=2 csbi=2)],
 2206         'icp'   => [qw(cpi=2 cbi=2 csbi=2)],
 2207         'nicp'  => [qw(cpi=0 cbi=0 csbi=0)],
 2208 
 2209         'closing-token-indentation=0' => [qw(cpi=0 cbi=0 csbi=0)],
 2210         'closing-token-indentation=1' => [qw(cpi=1 cbi=1 csbi=1)],
 2211         'closing-token-indentation=2' => [qw(cpi=2 cbi=2 csbi=2)],
 2212         'indent-closing-paren'        => [qw(cpi=2 cbi=2 csbi=2)],
 2213         'noindent-closing-paren'      => [qw(cpi=0 cbi=0 csbi=0)],
 2214 
 2215         'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
 2216         'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
 2217         'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
 2218 
 2219         'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
 2220         'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
 2221         'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
 2222 
 2223         'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
 2224         'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
 2225         'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
 2226 
 2227         'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
 2228         'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
 2229         'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
 2230 
 2231         'otr'                   => [qw(opr ohbr osbr)],
 2232         'opening-token-right'   => [qw(opr ohbr osbr)],
 2233         'notr'                  => [qw(nopr nohbr nosbr)],
 2234         'noopening-token-right' => [qw(nopr nohbr nosbr)],
 2235 
 2236         'sot'                    => [qw(sop sohb sosb)],
 2237         'nsot'                   => [qw(nsop nsohb nsosb)],
 2238         'stack-opening-tokens'   => [qw(sop sohb sosb)],
 2239         'nostack-opening-tokens' => [qw(nsop nsohb nsosb)],
 2240 
 2241         'sct'                    => [qw(scp schb scsb)],
 2242         'stack-closing-tokens'   => => [qw(scp schb scsb)],
 2243         'nsct'                   => [qw(nscp nschb nscsb)],
 2244         'nostack-closing-tokens' => [qw(nscp nschb nscsb)],
 2245 
 2246         'sac'                    => [qw(sot sct)],
 2247         'nsac'                   => [qw(nsot nsct)],
 2248         'stack-all-containers'   => [qw(sot sct)],
 2249         'nostack-all-containers' => [qw(nsot nsct)],
 2250 
 2251         'act=0'                      => [qw(pt=0 sbt=0 bt=0 bbt=0)],
 2252         'act=1'                      => [qw(pt=1 sbt=1 bt=1 bbt=1)],
 2253         'act=2'                      => [qw(pt=2 sbt=2 bt=2 bbt=2)],
 2254         'all-containers-tightness=0' => [qw(pt=0 sbt=0 bt=0 bbt=0)],
 2255         'all-containers-tightness=1' => [qw(pt=1 sbt=1 bt=1 bbt=1)],
 2256         'all-containers-tightness=2' => [qw(pt=2 sbt=2 bt=2 bbt=2)],
 2257 
 2258         'stack-opening-block-brace'   => [qw(bbvt=2 bbvtl=*)],
 2259         'sobb'                        => [qw(bbvt=2 bbvtl=*)],
 2260         'nostack-opening-block-brace' => [qw(bbvt=0)],
 2261         'nsobb'                       => [qw(bbvt=0)],
 2262 
 2263         'converge'   => [qw(it=4)],
 2264         'noconverge' => [qw(it=1)],
 2265         'conv'       => [qw(it=4)],
 2266         'nconv'      => [qw(it=1)],
 2267 
 2268         # 'mangle' originally deleted pod and comments, but to keep it
 2269         # reversible, it no longer does.  But if you really want to
 2270         # delete them, just use:
 2271         #   -mangle -dac
 2272 
 2273         # An interesting use for 'mangle' is to do this:
 2274         #    perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
 2275         # which will form as many one-line blocks as possible
 2276 
 2277         'mangle' => [
 2278             qw(
 2279               check-syntax
 2280               keep-old-blank-lines=0
 2281               delete-old-newlines
 2282               delete-old-whitespace
 2283               delete-semicolons
 2284               indent-columns=0
 2285               maximum-consecutive-blank-lines=0
 2286               maximum-line-length=100000
 2287               noadd-newlines
 2288               noadd-semicolons
 2289               noadd-whitespace
 2290               noblanks-before-blocks
 2291               blank-lines-before-subs=0
 2292               blank-lines-before-packages=0
 2293               notabs
 2294               )
 2295         ],
 2296 
 2297         # 'extrude' originally deleted pod and comments, but to keep it
 2298         # reversible, it no longer does.  But if you really want to
 2299         # delete them, just use
 2300         #   extrude -dac
 2301         #
 2302         # An interesting use for 'extrude' is to do this:
 2303         #    perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
 2304         # which will break up all one-line blocks.
 2305         #
 2306         # Removed 'check-syntax' option, which is unsafe because it may execute
 2307         # code in BEGIN blocks.  Example 'Moose/debugger-duck_type.t'.
 2308 
 2309         'extrude' => [
 2310             qw(
 2311               ci=0
 2312               delete-old-newlines
 2313               delete-old-whitespace
 2314               delete-semicolons
 2315               indent-columns=0
 2316               maximum-consecutive-blank-lines=0
 2317               maximum-line-length=1
 2318               noadd-semicolons
 2319               noadd-whitespace
 2320               noblanks-before-blocks
 2321               blank-lines-before-subs=0
 2322               blank-lines-before-packages=0
 2323               nofuzzy-line-length
 2324               notabs
 2325               norecombine
 2326               )
 2327         ],
 2328 
 2329         # this style tries to follow the GNU Coding Standards (which do
 2330         # not really apply to perl but which are followed by some perl
 2331         # programmers).
 2332         'gnu-style' => [
 2333             qw(
 2334               lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1
 2335               )
 2336         ],
 2337 
 2338         # Style suggested in Damian Conway's Perl Best Practices
 2339         'perl-best-practices' => [
 2340             qw(l=78 i=4 ci=4 st se vt=2 cti=0 pt=1 bt=1 sbt=1 bbt=1 nsfs nolq),
 2341 q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=)
 2342         ],
 2343 
 2344         # Additional styles can be added here
 2345     );
 2346 
 2347     Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
 2348 
 2349     # Uncomment next line to dump all expansions for debugging:
 2350     # dump_short_names(\%expansion);
 2351     return (
 2352         \@option_string,   \@defaults, \%expansion,
 2353         \%option_category, \%option_range
 2354     );
 2355 
 2356 }    # end of generate_options
 2357 
 2358 # Memoize process_command_line. Given same @ARGV passed in, return same
 2359 # values and same @ARGV back.
 2360 # This patch was supplied by Jonathan Swartz Nov 2012 and significantly speeds
 2361 # up masontidy (https://metacpan.org/module/masontidy)
 2362 
 2363 my %process_command_line_cache;
 2364 
 2365 sub process_command_line {
 2366 
 2367     my @q = @_;
 2368     my (
 2369         $perltidyrc_stream,  $is_Windows, $Windows_type,
 2370         $rpending_complaint, $dump_options_type
 2371     ) = @q;
 2372 
 2373     my $use_cache = !defined($perltidyrc_stream) && !$dump_options_type;
 2374     if ($use_cache) {
 2375         my $cache_key = join( chr(28), @ARGV );
 2376         if ( my $result = $process_command_line_cache{$cache_key} ) {
 2377             my ( $argv, @retvals ) = @{$result};
 2378             @ARGV = @{$argv};
 2379             return @retvals;
 2380         }
 2381         else {
 2382             my @retvals = _process_command_line(@q);
 2383             $process_command_line_cache{$cache_key} = [ \@ARGV, @retvals ]
 2384               if $retvals[0]->{'memoize'};
 2385             return @retvals;
 2386         }
 2387     }
 2388     else {
 2389         return _process_command_line(@q);
 2390     }
 2391 }
 2392 
 2393 # (note the underscore here)
 2394 sub _process_command_line {
 2395 
 2396     my (
 2397         $perltidyrc_stream,  $is_Windows, $Windows_type,
 2398         $rpending_complaint, $dump_options_type
 2399     ) = @_;
 2400 
 2401     use Getopt::Long;
 2402 
 2403     # Save any current Getopt::Long configuration
 2404     # and set to Getopt::Long defaults.  Use eval to avoid
 2405     # breaking old versions of Perl without these routines.
 2406     # Previous configuration is reset at the exit of this routine.
 2407     my $glc;
 2408     eval { $glc = Getopt::Long::Configure() };
 2409     unless ($@) {
 2410         eval { Getopt::Long::ConfigDefaults() };
 2411     }
 2412     else { $glc = undef }
 2413 
 2414     my (
 2415         $roption_string,   $rdefaults, $rexpansion,
 2416         $roption_category, $roption_range
 2417     ) = generate_options();
 2418 
 2419     #---------------------------------------------------------------
 2420     # set the defaults by passing the above list through GetOptions
 2421     #---------------------------------------------------------------
 2422     my %Opts = ();
 2423     {
 2424         local @ARGV = ();
 2425 
 2426         # do not load the defaults if we are just dumping perltidyrc
 2427         unless ( $dump_options_type eq 'perltidyrc' ) {
 2428             for my $i ( @{$rdefaults} ) { push @ARGV, "--" . $i }
 2429         }
 2430         if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
 2431             Die(
 2432 "Programming Bug reported by 'GetOptions': error in setting default options"
 2433             );
 2434         }
 2435     }
 2436 
 2437     my $word;
 2438     my @raw_options        = ();
 2439     my $config_file        = "";
 2440     my $saw_ignore_profile = 0;
 2441     my $saw_dump_profile   = 0;
 2442 
 2443     #---------------------------------------------------------------
 2444     # Take a first look at the command-line parameters.  Do as many
 2445     # immediate dumps as possible, which can avoid confusion if the
 2446     # perltidyrc file has an error.
 2447     #---------------------------------------------------------------
 2448     foreach my $i (@ARGV) {
 2449 
 2450         $i =~ s/^--/-/;
 2451         if ( $i =~ /^-(npro|noprofile|no-profile)$/ ) {
 2452             $saw_ignore_profile = 1;
 2453         }
 2454 
 2455         # note: this must come before -pro and -profile, below:
 2456         elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
 2457             $saw_dump_profile = 1;
 2458         }
 2459         elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
 2460             if ($config_file) {
 2461                 Warn(
 2462 "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n"
 2463                 );
 2464             }
 2465             $config_file = $2;
 2466 
 2467             # resolve <dir>/.../<file>, meaning look upwards from directory
 2468             if ( defined($config_file) ) {
 2469                 if ( my ( $start_dir, $search_file ) =
 2470                     ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
 2471                 {
 2472                     $start_dir = '.' if !$start_dir;
 2473                     $start_dir = Cwd::realpath($start_dir);
 2474                     if ( my $found_file =
 2475                         find_file_upwards( $start_dir, $search_file ) )
 2476                     {
 2477                         $config_file = $found_file;
 2478                     }
 2479                 }
 2480             }
 2481             unless ( -e $config_file ) {
 2482                 Warn("cannot find file given with -pro=$config_file: $!\n");
 2483                 $config_file = "";
 2484             }
 2485         }
 2486         elsif ( $i =~ /^-(pro|profile)=?$/ ) {
 2487             Die("usage: -pro=filename or --profile=filename, no spaces\n");
 2488         }
 2489         elsif ( $i =~ /^-(help|h|HELP|H|\?)$/ ) {
 2490             usage();
 2491             Exit(0);
 2492         }
 2493         elsif ( $i =~ /^-(version|v)$/ ) {
 2494             show_version();
 2495             Exit(0);
 2496         }
 2497         elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
 2498             dump_defaults( @{$rdefaults} );
 2499             Exit(0);
 2500         }
 2501         elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
 2502             dump_long_names( @{$roption_string} );
 2503             Exit(0);
 2504         }
 2505         elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
 2506             dump_short_names($rexpansion);
 2507             Exit(0);
 2508         }
 2509         elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
 2510             Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
 2511             Exit(0);
 2512         }
 2513     }
 2514 
 2515     if ( $saw_dump_profile && $saw_ignore_profile ) {
 2516         Warn("No profile to dump because of -npro\n");
 2517         Exit(1);
 2518     }
 2519 
 2520     #---------------------------------------------------------------
 2521     # read any .perltidyrc configuration file
 2522     #---------------------------------------------------------------
 2523     unless ($saw_ignore_profile) {
 2524 
 2525         # resolve possible conflict between $perltidyrc_stream passed
 2526         # as call parameter to perltidy and -pro=filename on command
 2527         # line.
 2528         if ($perltidyrc_stream) {
 2529             if ($config_file) {
 2530                 Warn(<<EOM);
 2531  Conflict: a perltidyrc configuration file was specified both as this
 2532  perltidy call parameter: $perltidyrc_stream 
 2533  and with this -profile=$config_file.
 2534  Using -profile=$config_file.
 2535 EOM
 2536             }
 2537             else {
 2538                 $config_file = $perltidyrc_stream;
 2539             }
 2540         }
 2541 
 2542         # look for a config file if we don't have one yet
 2543         my $rconfig_file_chatter;
 2544         ${$rconfig_file_chatter} = "";
 2545         $config_file =
 2546           find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
 2547             $rpending_complaint )
 2548           unless $config_file;
 2549 
 2550         # open any config file
 2551         my $fh_config;
 2552         if ($config_file) {
 2553             ( $fh_config, $config_file ) =
 2554               Perl::Tidy::streamhandle( $config_file, 'r' );
 2555             unless ($fh_config) {
 2556                 ${$rconfig_file_chatter} .=
 2557                   "# $config_file exists but cannot be opened\n";
 2558             }
 2559         }
 2560 
 2561         if ($saw_dump_profile) {
 2562             dump_config_file( $fh_config, $config_file, $rconfig_file_chatter );
 2563             Exit(0);
 2564         }
 2565 
 2566         if ($fh_config) {
 2567 
 2568             my ( $rconfig_list, $death_message ) =
 2569               read_config_file( $fh_config, $config_file, $rexpansion );
 2570             Die($death_message) if ($death_message);
 2571 
 2572             # process any .perltidyrc parameters right now so we can
 2573             # localize errors
 2574             if ( @{$rconfig_list} ) {
 2575                 local @ARGV = @{$rconfig_list};
 2576 
 2577                 expand_command_abbreviations( $rexpansion, \@raw_options,
 2578                     $config_file );
 2579 
 2580                 if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
 2581                     Die(
 2582 "Error in this config file: $config_file  \nUse -npro to ignore this file, -h for help'\n"
 2583                     );
 2584                 }
 2585 
 2586                 # Anything left in this local @ARGV is an error and must be
 2587                 # invalid bare words from the configuration file.  We cannot
 2588                 # check this earlier because bare words may have been valid
 2589                 # values for parameters.  We had to wait for GetOptions to have
 2590                 # a look at @ARGV.
 2591                 if (@ARGV) {
 2592                     my $count = @ARGV;
 2593                     my $str   = "\'" . pop(@ARGV) . "\'";
 2594                     while ( my $param = pop(@ARGV) ) {
 2595                         if ( length($str) < 70 ) {
 2596                             $str .= ", '$param'";
 2597                         }
 2598                         else {
 2599                             $str .= ", ...";
 2600                             last;
 2601                         }
 2602                     }
 2603                     Die(<<EOM);
 2604 There are $count unrecognized values in the configuration file '$config_file':
 2605 $str
 2606 Use leading dashes for parameters.  Use -npro to ignore this file.
 2607 EOM
 2608                 }
 2609 
 2610                 # Undo any options which cause premature exit.  They are not
 2611                 # appropriate for a config file, and it could be hard to
 2612                 # diagnose the cause of the premature exit.
 2613                 foreach (
 2614                     qw{
 2615                     dump-cuddled-block-list
 2616                     dump-defaults
 2617                     dump-long-names
 2618                     dump-options
 2619                     dump-profile
 2620                     dump-short-names
 2621                     dump-token-types
 2622                     dump-want-left-space
 2623                     dump-want-right-space
 2624                     help
 2625                     stylesheet
 2626                     version
 2627                     }
 2628                   )
 2629                 {
 2630 
 2631                     if ( defined( $Opts{$_} ) ) {
 2632                         delete $Opts{$_};
 2633                         Warn("ignoring --$_ in config file: $config_file\n");
 2634                     }
 2635                 }
 2636             }
 2637         }
 2638     }
 2639 
 2640     #---------------------------------------------------------------
 2641     # now process the command line parameters
 2642     #---------------------------------------------------------------
 2643     expand_command_abbreviations( $rexpansion, \@raw_options, $config_file );
 2644 
 2645     local $SIG{'__WARN__'} = sub { Warn( $_[0] ) };
 2646     if ( !GetOptions( \%Opts, @{$roption_string} ) ) {
 2647         Die("Error on command line; for help try 'perltidy -h'\n");
 2648     }
 2649 
 2650     # reset Getopt::Long configuration back to its previous value
 2651     eval { Getopt::Long::Configure($glc) } if defined $glc;
 2652 
 2653     return ( \%Opts, $config_file, \@raw_options, $roption_string,
 2654         $rexpansion, $roption_category, $roption_range );
 2655 }    # end of _process_command_line
 2656 
 2657 sub check_options {
 2658 
 2659     my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_;
 2660 
 2661     #---------------------------------------------------------------
 2662     # check and handle any interactions among the basic options..
 2663     #---------------------------------------------------------------
 2664 
 2665     # Since -vt, -vtc, and -cti are abbreviations, but under
 2666     # msdos, an unquoted input parameter like vtc=1 will be
 2667     # seen as 2 parameters, vtc and 1, so the abbreviations
 2668     # won't be seen.  Therefore, we will catch them here if
 2669     # they get through.
 2670 
 2671     if ( defined $rOpts->{'vertical-tightness'} ) {
 2672         my $vt = $rOpts->{'vertical-tightness'};
 2673         $rOpts->{'paren-vertical-tightness'}          = $vt;
 2674         $rOpts->{'square-bracket-vertical-tightness'} = $vt;
 2675         $rOpts->{'brace-vertical-tightness'}          = $vt;
 2676     }
 2677 
 2678     if ( defined $rOpts->{'vertical-tightness-closing'} ) {
 2679         my $vtc = $rOpts->{'vertical-tightness-closing'};
 2680         $rOpts->{'paren-vertical-tightness-closing'}          = $vtc;
 2681         $rOpts->{'square-bracket-vertical-tightness-closing'} = $vtc;
 2682         $rOpts->{'brace-vertical-tightness-closing'}          = $vtc;
 2683     }
 2684 
 2685     if ( defined $rOpts->{'closing-token-indentation'} ) {
 2686         my $cti = $rOpts->{'closing-token-indentation'};
 2687         $rOpts->{'closing-square-bracket-indentation'} = $cti;
 2688         $rOpts->{'closing-brace-indentation'}          = $cti;
 2689         $rOpts->{'closing-paren-indentation'}          = $cti;
 2690     }
 2691 
 2692     # In quiet mode, there is no log file and hence no way to report
 2693     # results of syntax check, so don't do it.
 2694     if ( $rOpts->{'quiet'} ) {
 2695         $rOpts->{'check-syntax'} = 0;
 2696     }
 2697 
 2698     # can't check syntax if no output
 2699     if ( $rOpts->{'format'} ne 'tidy' ) {
 2700         $rOpts->{'check-syntax'} = 0;
 2701     }
 2702 
 2703     # Never let Windows 9x/Me systems run syntax check -- this will prevent a
 2704     # wide variety of nasty problems on these systems, because they cannot
 2705     # reliably run backticks.  Don't even think about changing this!
 2706     if (   $rOpts->{'check-syntax'}
 2707         && $is_Windows
 2708         && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
 2709     {
 2710         $rOpts->{'check-syntax'} = 0;
 2711     }
 2712 
 2713     ###########################################################################
 2714     # Added Dec 2017: Deactivating check-syntax for all systems for safety
 2715     # because unexpected results can occur when code in BEGIN blocks is
 2716     # executed.  This flag was included to help check for perltidy mistakes,
 2717     # and may still be useful for debugging.  To activate for testing comment
 2718     # out the next three lines.  Also fix sub 'do_check_syntax' in this file.
 2719     ###########################################################################
 2720     else {
 2721         $rOpts->{'check-syntax'} = 0;
 2722     }
 2723 
 2724     # It's really a bad idea to check syntax as root unless you wrote
 2725     # the script yourself.  FIXME: not sure if this works with VMS
 2726     unless ($is_Windows) {
 2727 
 2728         if ( $< == 0 && $rOpts->{'check-syntax'} ) {
 2729             $rOpts->{'check-syntax'} = 0;
 2730             ${$rpending_complaint} .=
 2731 "Syntax check deactivated for safety; you shouldn't run this as root\n";
 2732         }
 2733     }
 2734 
 2735     # check iteration count and quietly fix if necessary:
 2736     # - iterations option only applies to code beautification mode
 2737     # - the convergence check should stop most runs on iteration 2, and
 2738     #   virtually all on iteration 3.  But we'll allow up to 6.
 2739     if ( $rOpts->{'format'} ne 'tidy' ) {
 2740         $rOpts->{'iterations'} = 1;
 2741     }
 2742     elsif ( defined( $rOpts->{'iterations'} ) ) {
 2743         if    ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 }
 2744         elsif ( $rOpts->{'iterations'} > 6 )  { $rOpts->{'iterations'} = 6 }
 2745     }
 2746     else {
 2747         $rOpts->{'iterations'} = 1;
 2748     }
 2749 
 2750     my $check_blank_count = sub {
 2751         my ( $key, $abbrev ) = @_;
 2752         if ( $rOpts->{$key} ) {
 2753             if ( $rOpts->{$key} < 0 ) {
 2754                 $rOpts->{$key} = 0;
 2755                 Warn("negative value of $abbrev, setting 0\n");
 2756             }
 2757             if ( $rOpts->{$key} > 100 ) {
 2758                 Warn("unreasonably large value of $abbrev, reducing\n");
 2759                 $rOpts->{$key} = 100;
 2760             }
 2761         }
 2762     };
 2763 
 2764     # check for reasonable number of blank lines and fix to avoid problems
 2765     $check_blank_count->( 'blank-lines-before-subs',          '-blbs' );
 2766     $check_blank_count->( 'blank-lines-before-packages',      '-blbp' );
 2767     $check_blank_count->( 'blank-lines-after-block-opening',  '-blao' );
 2768     $check_blank_count->( 'blank-lines-before-block-closing', '-blbc' );
 2769 
 2770     # setting a non-negative logfile gap causes logfile to be saved
 2771     if ( defined( $rOpts->{'logfile-gap'} ) && $rOpts->{'logfile-gap'} >= 0 ) {
 2772         $rOpts->{'logfile'} = 1;
 2773     }
 2774 
 2775     # set short-cut flag when only indentation is to be done.
 2776     # Note that the user may or may not have already set the
 2777     # indent-only flag.
 2778     if (   !$rOpts->{'add-whitespace'}
 2779         && !$rOpts->{'delete-old-whitespace'}
 2780         && !$rOpts->{'add-newlines'}
 2781         && !$rOpts->{'delete-old-newlines'} )
 2782     {
 2783         $rOpts->{'indent-only'} = 1;
 2784     }
 2785 
 2786     # -isbc implies -ibc
 2787     if ( $rOpts->{'indent-spaced-block-comments'} ) {
 2788         $rOpts->{'indent-block-comments'} = 1;
 2789     }
 2790 
 2791     # -bli flag implies -bl
 2792     if ( $rOpts->{'brace-left-and-indent'} ) {
 2793         $rOpts->{'opening-brace-on-new-line'} = 1;
 2794     }
 2795 
 2796     if (   $rOpts->{'opening-brace-always-on-right'}
 2797         && $rOpts->{'opening-brace-on-new-line'} )
 2798     {
 2799         Warn(<<EOM);
 2800  Conflict: you specified both 'opening-brace-always-on-right' (-bar) and 
 2801   'opening-brace-on-new-line' (-bl).  Ignoring -bl. 
 2802 EOM
 2803         $rOpts->{'opening-brace-on-new-line'} = 0;
 2804     }
 2805 
 2806     # it simplifies things if -bl is 0 rather than undefined
 2807     if ( !defined( $rOpts->{'opening-brace-on-new-line'} ) ) {
 2808         $rOpts->{'opening-brace-on-new-line'} = 0;
 2809     }
 2810 
 2811     # -sbl defaults to -bl if not defined
 2812     if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) {
 2813         $rOpts->{'opening-sub-brace-on-new-line'} =
 2814           $rOpts->{'opening-brace-on-new-line'};
 2815     }
 2816 
 2817     if ( $rOpts->{'entab-leading-whitespace'} ) {
 2818         if ( $rOpts->{'entab-leading-whitespace'} < 0 ) {
 2819             Warn("-et=n must use a positive integer; ignoring -et\n");
 2820             $rOpts->{'entab-leading-whitespace'} = undef;
 2821         }
 2822 
 2823         # entab leading whitespace has priority over the older 'tabs' option
 2824         if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; }
 2825     }
 2826 
 2827     # set a default tabsize to be used in guessing the starting indentation
 2828     # level if and only if this run does not use tabs and the old code does
 2829     # use tabs
 2830     if ( $rOpts->{'default-tabsize'} ) {
 2831         if ( $rOpts->{'default-tabsize'} < 0 ) {
 2832             Warn("negative value of -dt, setting 0\n");
 2833             $rOpts->{'default-tabsize'} = 0;
 2834         }
 2835         if ( $rOpts->{'default-tabsize'} > 20 ) {
 2836             Warn("unreasonably large value of -dt, reducing\n");
 2837             $rOpts->{'default-tabsize'} = 20;
 2838         }
 2839     }
 2840     else {
 2841         $rOpts->{'default-tabsize'} = 8;
 2842     }
 2843 
 2844     # Define $tabsize, the number of spaces per tab for use in
 2845     # guessing the indentation of source lines with leading tabs.
 2846     # Assume same as for this run if tabs are used , otherwise assume
 2847     # a default value, typically 8
 2848     my $tabsize =
 2849         $rOpts->{'entab-leading-whitespace'}
 2850       ? $rOpts->{'entab-leading-whitespace'}
 2851       : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'}
 2852       :                    $rOpts->{'default-tabsize'};
 2853     return $tabsize;
 2854 }
 2855 
 2856 sub find_file_upwards {
 2857     my ( $search_dir, $search_file ) = @_;
 2858 
 2859     $search_dir  =~ s{/+$}{};
 2860     $search_file =~ s{^/+}{};
 2861 
 2862     while (1) {
 2863         my $try_path = "$search_dir/$search_file";
 2864         if ( -f $try_path ) {
 2865             return $try_path;
 2866         }
 2867         elsif ( $search_dir eq '/' ) {
 2868             return;
 2869         }
 2870         else {
 2871             $search_dir = dirname($search_dir);
 2872         }
 2873     }
 2874 
 2875     # This return is for Perl-Critic.
 2876     # We shouldn't get out of the while loop without a return
 2877     return;
 2878 }
 2879 
 2880 sub expand_command_abbreviations {
 2881 
 2882     # go through @ARGV and expand any abbreviations
 2883 
 2884     my ( $rexpansion, $rraw_options, $config_file ) = @_;
 2885 
 2886     # set a pass limit to prevent an infinite loop;
 2887     # 10 should be plenty, but it may be increased to allow deeply
 2888     # nested expansions.
 2889     my $max_passes = 10;
 2890     my @new_argv   = ();
 2891 
 2892     # keep looping until all expansions have been converted into actual
 2893     # dash parameters..
 2894     foreach my $pass_count ( 0 .. $max_passes ) {
 2895         my @new_argv     = ();
 2896         my $abbrev_count = 0;
 2897 
 2898         # loop over each item in @ARGV..
 2899         foreach my $word (@ARGV) {
 2900 
 2901             # convert any leading 'no-' to just 'no'
 2902             if ( $word =~ /^(-[-]?no)-(.*)/ ) { $word = $1 . $2 }
 2903 
 2904             # if it is a dash flag (instead of a file name)..
 2905             if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
 2906 
 2907                 my $abr   = $1;
 2908                 my $flags = $2;
 2909 
 2910                 # save the raw input for debug output in case of circular refs
 2911                 if ( $pass_count == 0 ) {
 2912                     push( @{$rraw_options}, $word );
 2913                 }
 2914 
 2915                 # recombine abbreviation and flag, if necessary,
 2916                 # to allow abbreviations with arguments such as '-vt=1'
 2917                 if ( $rexpansion->{ $abr . $flags } ) {
 2918                     $abr   = $abr . $flags;
 2919                     $flags = "";
 2920                 }
 2921 
 2922                 # if we see this dash item in the expansion hash..
 2923                 if ( $rexpansion->{$abr} ) {
 2924                     $abbrev_count++;
 2925 
 2926                     # stuff all of the words that it expands to into the
 2927                     # new arg list for the next pass
 2928                     foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
 2929                         next unless $abbrev;    # for safety; shouldn't happen
 2930                         push( @new_argv, '--' . $abbrev . $flags );
 2931                     }
 2932                 }
 2933 
 2934                 # not in expansion hash, must be actual long name
 2935                 else {
 2936                     push( @new_argv, $word );
 2937                 }
 2938             }
 2939 
 2940             # not a dash item, so just save it for the next pass
 2941             else {
 2942                 push( @new_argv, $word );
 2943             }
 2944         }    # end of this pass
 2945 
 2946         # update parameter list @ARGV to the new one
 2947         @ARGV = @new_argv;
 2948         last unless ( $abbrev_count > 0 );
 2949 
 2950         # make sure we are not in an infinite loop
 2951         if ( $pass_count == $max_passes ) {
 2952             local $" = ')(';
 2953             Warn(<<EOM);
 2954 I'm tired. We seem to be in an infinite loop trying to expand aliases.
 2955 Here are the raw options;
 2956 (rraw_options)
 2957 EOM
 2958             my $num = @new_argv;
 2959             if ( $num < 50 ) {
 2960                 Warn(<<EOM);
 2961 After $max_passes passes here is ARGV
 2962 (@new_argv)
 2963 EOM
 2964             }
 2965             else {
 2966                 Warn(<<EOM);
 2967 After $max_passes passes ARGV has $num entries
 2968 EOM
 2969             }
 2970 
 2971             if ($config_file) {
 2972                 Die(<<"DIE");
 2973 Please check your configuration file $config_file for circular-references. 
 2974 To deactivate it, use -npro.
 2975 DIE
 2976             }
 2977             else {
 2978                 Die(<<'DIE');
 2979 Program bug - circular-references in the %expansion hash, probably due to
 2980 a recent program change.
 2981 DIE
 2982             }
 2983         }    # end of check for circular references
 2984     }    # end of loop over all passes
 2985     return;
 2986 }
 2987 
 2988 # Debug routine -- this will dump the expansion hash
 2989 sub dump_short_names {
 2990     my $rexpansion = shift;
 2991     print STDOUT <<EOM;
 2992 List of short names.  This list shows how all abbreviations are
 2993 translated into other abbreviations and, eventually, into long names.
 2994 New abbreviations may be defined in a .perltidyrc file.  
 2995 For a list of all long names, use perltidy --dump-long-names (-dln).
 2996 --------------------------------------------------------------------------
 2997 EOM
 2998     foreach my $abbrev ( sort keys %$rexpansion ) {
 2999         my @list = @{ $rexpansion->{$abbrev} };
 3000         print STDOUT "$abbrev --> @list\n";
 3001     }
 3002     return;
 3003 }
 3004 
 3005 sub check_vms_filename {
 3006 
 3007     # given a valid filename (the perltidy input file)
 3008     # create a modified filename and separator character
 3009     # suitable for VMS.
 3010     #
 3011     # Contributed by Michael Cartmell
 3012     #
 3013     my $filename = shift;
 3014     my ( $base, $path ) = fileparse($filename);
 3015 
 3016     # remove explicit ; version
 3017     $base =~ s/;-?\d*$//
 3018 
 3019       # remove explicit . version ie two dots in filename NB ^ escapes a dot
 3020       or $base =~ s/(          # begin capture $1
 3021                   (?:^|[^^])\. # match a dot not preceded by a caret
 3022                   (?:          # followed by nothing
 3023                     |          # or
 3024                     .*[^^]     # anything ending in a non caret
 3025                   )
 3026                 )              # end capture $1
 3027                 \.-?\d*$       # match . version number
 3028               /$1/x;
 3029 
 3030     # normalise filename, if there are no unescaped dots then append one
 3031     $base .= '.' unless $base =~ /(?:^|[^^])\./;
 3032 
 3033     # if we don't already have an extension then we just append the extension
 3034     my $separator = ( $base =~ /\.$/ ) ? "" : "_";
 3035     return ( $path . $base, $separator );
 3036 }
 3037 
 3038 sub Win_OS_Type {
 3039 
 3040     # TODO: are these more standard names?
 3041     # Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003
 3042 
 3043     # Returns a string that determines what MS OS we are on.
 3044     # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net,Win2003
 3045     # Returns blank string if not an MS system.
 3046     # Original code contributed by: Yves Orton
 3047     # We need to know this to decide where to look for config files
 3048 
 3049     my $rpending_complaint = shift;
 3050     my $os                 = "";
 3051     return $os unless $^O =~ /win32|dos/i;    # is it a MS box?
 3052 
 3053     # Systems built from Perl source may not have Win32.pm
 3054     # But probably have Win32::GetOSVersion() anyway so the
 3055     # following line is not 'required':
 3056     # return $os unless eval('require Win32');
 3057 
 3058     # Use the standard API call to determine the version
 3059     my ( $undef, $major, $minor, $build, $id );
 3060     eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() };
 3061 
 3062     #
 3063     #    NAME                   ID   MAJOR  MINOR
 3064     #    Windows NT 4           2      4       0
 3065     #    Windows 2000           2      5       0
 3066     #    Windows XP             2      5       1
 3067     #    Windows Server 2003    2      5       2
 3068 
 3069     return "win32s" unless $id;    # If id==0 then its a win32s box.
 3070     $os = {                        # Magic numbers from MSDN
 3071                                    # documentation of GetOSVersion
 3072         1 => {
 3073             0  => "95",
 3074             10 => "98",
 3075             90 => "Me"
 3076         },
 3077         2 => {
 3078             0  => "2000",          # or NT 4, see below
 3079             1  => "XP/.Net",
 3080             2  => "Win2003",
 3081             51 => "NT3.51"
 3082         }
 3083     }->{$id}->{$minor};
 3084 
 3085     # If $os is undefined, the above code is out of date.  Suggested updates
 3086     # are welcome.
 3087     unless ( defined $os ) {
 3088         $os = "";
 3089 
 3090         # Deactivated this message 20180322 because it was needlessly
 3091         # causing some test scripts to fail.  Need help from someone
 3092         # with expertise in Windows to decide what is possible with windows.
 3093         ${$rpending_complaint} .= <<EOS if (0);
 3094 Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
 3095 We won't be able to look for a system-wide config file.
 3096 EOS
 3097     }
 3098 
 3099     # Unfortunately the logic used for the various versions isn't so clever..
 3100     # so we have to handle an outside case.
 3101     return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os;
 3102 }
 3103 
 3104 sub is_unix {
 3105     return
 3106          ( $^O !~ /win32|dos/i )
 3107       && ( $^O ne 'VMS' )
 3108       && ( $^O ne 'OS2' )
 3109       && ( $^O ne 'MacOS' );
 3110 }
 3111 
 3112 sub look_for_Windows {
 3113 
 3114     # determine Windows sub-type and location of
 3115     # system-wide configuration files
 3116     my $rpending_complaint = shift;
 3117     my $is_Windows         = ( $^O =~ /win32|dos/i );
 3118     my $Windows_type;
 3119     $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows;
 3120     return ( $is_Windows, $Windows_type );
 3121 }
 3122 
 3123 sub find_config_file {
 3124 
 3125     # look for a .perltidyrc configuration file
 3126     # For Windows also look for a file named perltidy.ini
 3127     my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
 3128         $rpending_complaint ) = @_;
 3129 
 3130     ${$rconfig_file_chatter} .= "# Config file search...system reported as:";
 3131     if ($is_Windows) {
 3132         ${$rconfig_file_chatter} .= "Windows $Windows_type\n";
 3133     }
 3134     else {
 3135         ${$rconfig_file_chatter} .= " $^O\n";
 3136     }
 3137 
 3138     # sub to check file existence and record all tests
 3139     my $exists_config_file = sub {
 3140         my $config_file = shift;
 3141         return 0 unless $config_file;
 3142         ${$rconfig_file_chatter} .= "# Testing: $config_file\n";
 3143         return -f $config_file;
 3144     };
 3145 
 3146     # Sub to search upward for config file
 3147     my $resolve_config_file = sub {
 3148 
 3149         # resolve <dir>/.../<file>, meaning look upwards from directory
 3150         my $config_file = shift;
 3151         if ($config_file) {
 3152             if ( my ( $start_dir, $search_file ) =
 3153                 ( $config_file =~ m{^(.*)\.\.\./(.*)$} ) )
 3154             {
 3155                 ${$rconfig_file_chatter} .=
 3156                   "# Searching Upward: $config_file\n";
 3157                 $start_dir = '.' if !$start_dir;
 3158                 $start_dir = Cwd::realpath($start_dir);
 3159                 if ( my $found_file =
 3160                     find_file_upwards( $start_dir, $search_file ) )
 3161                 {
 3162                     $config_file = $found_file;
 3163                     ${$rconfig_file_chatter} .= "# Found: $config_file\n";
 3164                 }
 3165             }
 3166         }
 3167         return $config_file;
 3168     };
 3169 
 3170     my $config_file;
 3171 
 3172     # look in current directory first
 3173     $config_file = ".perltidyrc";
 3174     return $config_file if $exists_config_file->($config_file);
 3175     if ($is_Windows) {
 3176         $config_file = "perltidy.ini";
 3177         return $config_file if $exists_config_file->($config_file);
 3178     }
 3179 
 3180     # Default environment vars.
 3181     my @envs = qw(PERLTIDY HOME);
 3182 
 3183     # Check the NT/2k/XP locations, first a local machine def, then a
 3184     # network def
 3185     push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
 3186 
 3187     # Now go through the environment ...
 3188     foreach my $var (@envs) {
 3189         ${$rconfig_file_chatter} .= "# Examining: \$ENV{$var}";
 3190         if ( defined( $ENV{$var} ) ) {
 3191             ${$rconfig_file_chatter} .= " = $ENV{$var}\n";
 3192 
 3193             # test ENV{ PERLTIDY } as file:
 3194             if ( $var eq 'PERLTIDY' ) {
 3195                 $config_file = "$ENV{$var}";
 3196                 $config_file = $resolve_config_file->($config_file);
 3197                 return $config_file if $exists_config_file->($config_file);
 3198             }
 3199 
 3200             # test ENV as directory:
 3201             $config_file = catfile( $ENV{$var}, ".perltidyrc" );
 3202             $config_file = $resolve_config_file->($config_file);
 3203             return $config_file if $exists_config_file->($config_file);
 3204 
 3205             if ($is_Windows) {
 3206                 $config_file = catfile( $ENV{$var}, "perltidy.ini" );
 3207                 $config_file = $resolve_config_file->($config_file);
 3208                 return $config_file if $exists_config_file->($config_file);
 3209             }
 3210         }
 3211         else {
 3212             ${$rconfig_file_chatter} .= "\n";
 3213         }
 3214     }
 3215 
 3216     # then look for a system-wide definition
 3217     # where to look varies with OS
 3218     if ($is_Windows) {
 3219 
 3220         if ($Windows_type) {
 3221             my ( $os, $system, $allusers ) =
 3222               Win_Config_Locs( $rpending_complaint, $Windows_type );
 3223 
 3224             # Check All Users directory, if there is one.
 3225             # i.e. C:\Documents and Settings\User\perltidy.ini
 3226             if ($allusers) {
 3227 
 3228                 $config_file = catfile( $allusers, ".perltidyrc" );
 3229                 return $config_file if $exists_config_file->($config_file);
 3230 
 3231                 $config_file = catfile( $allusers, "perltidy.ini" );
 3232                 return $config_file if $exists_config_file->($config_file);
 3233             }
 3234 
 3235             # Check system directory.
 3236             # retain old code in case someone has been able to create
 3237             # a file with a leading period.
 3238             $config_file = catfile( $system, ".perltidyrc" );
 3239             return $config_file if $exists_config_file->($config_file);
 3240 
 3241             $config_file = catfile( $system, "perltidy.ini" );
 3242             return $config_file if $exists_config_file->($config_file);
 3243         }
 3244     }
 3245 
 3246     # Place to add customization code for other systems
 3247     elsif ( $^O eq 'OS2' ) {
 3248     }
 3249     elsif ( $^O eq 'MacOS' ) {
 3250     }
 3251     elsif ( $^O eq 'VMS' ) {
 3252     }
 3253 
 3254     # Assume some kind of Unix
 3255     else {
 3256 
 3257         $config_file = "/usr/local/etc/perltidyrc";
 3258         return $config_file if $exists_config_file->($config_file);
 3259 
 3260         $config_file = "/etc/perltidyrc";
 3261         return $config_file if $exists_config_file->($config_file);
 3262     }
 3263 
 3264     # Couldn't find a config file
 3265     return;
 3266 }
 3267 
 3268 sub Win_Config_Locs {
 3269 
 3270     # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
 3271     # or undef if its not a win32 OS.  In list context returns OS, System
 3272     # Directory, and All Users Directory.  All Users will be empty on a
 3273     # 9x/Me box.  Contributed by: Yves Orton.
 3274 
 3275     # Original coding:
 3276     # my $rpending_complaint = shift;
 3277     # my $os = (@_) ? shift : Win_OS_Type();
 3278 
 3279     my ( $rpending_complaint, $os ) = @_;
 3280     if ( !$os ) { $os = Win_OS_Type(); }
 3281 
 3282     return unless $os;
 3283 
 3284     my $system   = "";
 3285     my $allusers = "";
 3286 
 3287     if ( $os =~ /9[58]|Me/ ) {
 3288         $system = "C:/Windows";
 3289     }
 3290     elsif ( $os =~ /NT|XP|200?/ ) {
 3291         $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
 3292         $allusers =
 3293           ( $os =~ /NT/ )
 3294           ? "C:/WinNT/profiles/All Users/"
 3295           : "C:/Documents and Settings/All Users/";
 3296     }
 3297     else {
 3298 
 3299         # This currently would only happen on a win32s computer.  I don't have
 3300         # one to test, so I am unsure how to proceed.  Suggestions welcome!
 3301         ${$rpending_complaint} .=
 3302 "I dont know a sensible place to look for config files on an $os system.\n";
 3303         return;
 3304     }
 3305     return wantarray ? ( $os, $system, $allusers ) : $os;
 3306 }
 3307 
 3308 sub dump_config_file {
 3309     my ( $fh, $config_file, $rconfig_file_chatter ) = @_;
 3310     print STDOUT "$$rconfig_file_chatter";
 3311     if ($fh) {
 3312         print STDOUT "# Dump of file: '$config_file'\n";
 3313         while ( my $line = $fh->getline() ) { print STDOUT $line }
 3314         eval { $fh->close() };
 3315     }
 3316     else {
 3317         print STDOUT "# ...no config file found\n";
 3318     }
 3319     return;
 3320 }
 3321 
 3322 sub read_config_file {
 3323 
 3324     my ( $fh, $config_file, $rexpansion ) = @_;
 3325     my @config_list = ();
 3326 
 3327     # file is bad if non-empty $death_message is returned
 3328     my $death_message = "";
 3329 
 3330     my $name = undef;
 3331     my $line_no;
 3332     my $opening_brace_line;
 3333     while ( my $line = $fh->getline() ) {
 3334         $line_no++;
 3335         chomp $line;
 3336         ( $line, $death_message ) =
 3337           strip_comment( $line, $config_file, $line_no );
 3338         last if ($death_message);
 3339         next unless $line;
 3340         $line =~ s/^\s*(.*?)\s*$/$1/;    # trim both ends
 3341         next unless $line;
 3342 
 3343         my $body = $line;
 3344 
 3345         # Look for complete or partial abbreviation definition of the form
 3346         #     name { body }   or  name {   or    name { body
 3347         # See rules in perltidy's perldoc page
 3348         # Section: Other Controls - Creating a new abbreviation
 3349         if ( $line =~ /^((\w+)\s*\{)(.*)?$/ ) {
 3350             my $oldname = $name;
 3351             ( $name, $body ) = ( $2, $3 );
 3352 
 3353             # Cannot start new abbreviation unless old abbreviation is complete
 3354             last if ($opening_brace_line);
 3355 
 3356             $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// );
 3357 
 3358             # handle a new alias definition
 3359             if ( ${$rexpansion}{$name} ) {
 3360                 local $" = ')(';
 3361                 my @names = sort keys %$rexpansion;
 3362                 $death_message =
 3363                     "Here is a list of all installed aliases\n(@names)\n"
 3364                   . "Attempting to redefine alias ($name) in config file $config_file line $.\n";
 3365                 last;
 3366             }
 3367             ${$rexpansion}{$name} = [];
 3368         }
 3369 
 3370         # leading opening braces not allowed
 3371         elsif ( $line =~ /^{/ ) {
 3372             $opening_brace_line = undef;
 3373             $death_message =
 3374               "Unexpected '{' at line $line_no in config file '$config_file'\n";
 3375             last;
 3376         }
 3377 
 3378         # Look for abbreviation closing:    body }   or    }
 3379         elsif ( $line =~ /^(.*)?\}$/ ) {
 3380             $body = $1;
 3381             if ($opening_brace_line) {
 3382                 $opening_brace_line = undef;
 3383             }
 3384             else {
 3385                 $death_message =
 3386 "Unexpected '}' at line $line_no in config file '$config_file'\n";
 3387                 last;
 3388             }
 3389         }
 3390 
 3391         # Now store any parameters
 3392         if ($body) {
 3393 
 3394             my ( $rbody_parts, $msg ) = parse_args($body);
 3395             if ($msg) {
 3396                 $death_message = <<EOM;
 3397 Error reading file '$config_file' at line number $line_no.
 3398 $msg
 3399 Please fix this line or use -npro to avoid reading this file
 3400 EOM
 3401                 last;
 3402             }
 3403 
 3404             if ($name) {
 3405 
 3406                 # remove leading dashes if this is an alias
 3407                 foreach ( @{$rbody_parts} ) { s/^\-+//; }
 3408                 push @{ ${$rexpansion}{$name} }, @{$rbody_parts};
 3409             }
 3410             else {
 3411                 push( @config_list, @{$rbody_parts} );
 3412             }
 3413         }
 3414     }
 3415 
 3416     if ($opening_brace_line) {
 3417         $death_message =
 3418 "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n";
 3419     }
 3420     eval { $fh->close() };
 3421     return ( \@config_list, $death_message );
 3422 }
 3423 
 3424 sub strip_comment {
 3425 
 3426     # Strip any comment from a command line
 3427     my ( $instr, $config_file, $line_no ) = @_;
 3428     my $msg = "";
 3429 
 3430     # check for full-line comment
 3431     if ( $instr =~ /^\s*#/ ) {
 3432         return ( "", $msg );
 3433     }
 3434 
 3435     # nothing to do if no comments
 3436     if ( $instr !~ /#/ ) {
 3437         return ( $instr, $msg );
 3438     }
 3439 
 3440     # handle case of no quotes
 3441     elsif ( $instr !~ /['"]/ ) {
 3442 
 3443         # We now require a space before the # of a side comment
 3444         # this allows something like:
 3445         #    -sbcp=#
 3446         # Otherwise, it would have to be quoted:
 3447         #    -sbcp='#'
 3448         $instr =~ s/\s+\#.*$//;
 3449         return ( $instr, $msg );
 3450     }
 3451 
 3452     # handle comments and quotes
 3453     my $outstr     = "";
 3454     my $quote_char = "";
 3455     while (1) {
 3456 
 3457         # looking for ending quote character
 3458         if ($quote_char) {
 3459             if ( $instr =~ /\G($quote_char)/gc ) {
 3460                 $quote_char = "";
 3461                 $outstr .= $1;
 3462             }
 3463             elsif ( $instr =~ /\G(.)/gc ) {
 3464                 $outstr .= $1;
 3465             }
 3466 
 3467             # error..we reached the end without seeing the ending quote char
 3468             else {
 3469                 $msg = <<EOM;
 3470 Error reading file $config_file at line number $line_no.
 3471 Did not see ending quote character <$quote_char> in this text:
 3472 $instr
 3473 Please fix this line or use -npro to avoid reading this file
 3474 EOM
 3475                 last;
 3476             }
 3477         }
 3478 
 3479         # accumulating characters and looking for start of a quoted string
 3480         else {
 3481             if ( $instr =~ /\G([\"\'])/gc ) {
 3482                 $outstr .= $1;
 3483                 $quote_char = $1;
 3484             }
 3485 
 3486             # Note: not yet enforcing the space-before-hash rule for side
 3487             # comments if the parameter is quoted.
 3488             elsif ( $instr =~ /\G#/gc ) {
 3489                 last;
 3490             }
 3491             elsif ( $instr =~ /\G(.)/gc ) {
 3492                 $outstr .= $1;
 3493             }
 3494             else {
 3495                 last;
 3496             }
 3497         }
 3498     }
 3499     return ( $outstr, $msg );
 3500 }
 3501 
 3502 sub parse_args {
 3503 
 3504     # Parse a command string containing multiple string with possible
 3505     # quotes, into individual commands.  It might look like this, for example:
 3506     #
 3507     #    -wba=" + - "  -some-thing -wbb='. && ||'
 3508     #
 3509     # There is no need, at present, to handle escaped quote characters.
 3510     # (They are not perltidy tokens, so needn't be in strings).
 3511 
 3512     my ($body)     = @_;
 3513     my @body_parts = ();
 3514     my $quote_char = "";
 3515     my $part       = "";
 3516     my $msg        = "";
 3517     while (1) {
 3518 
 3519         # looking for ending quote character
 3520         if ($quote_char) {
 3521             if ( $body =~ /\G($quote_char)/gc ) {
 3522                 $quote_char = "";
 3523             }
 3524             elsif ( $body =~ /\G(.)/gc ) {
 3525                 $part .= $1;
 3526             }
 3527 
 3528             # error..we reached the end without seeing the ending quote char
 3529             else {
 3530                 if ( length($part) ) { push @body_parts, $part; }
 3531                 $msg = <<EOM;
 3532 Did not see ending quote character <$quote_char> in this text:
 3533 $body
 3534 EOM
 3535                 last;
 3536             }
 3537         }
 3538 
 3539         # accumulating characters and looking for start of a quoted string
 3540         else {
 3541             if ( $body =~ /\G([\"\'])/gc ) {
 3542                 $quote_char = $1;
 3543             }
 3544             elsif ( $body =~ /\G(\s+)/gc ) {
 3545                 if ( length($part) ) { push @body_parts, $part; }
 3546                 $part = "";
 3547             }
 3548             elsif ( $body =~ /\G(.)/gc ) {
 3549                 $part .= $1;
 3550             }
 3551             else {
 3552                 if ( length($part) ) { push @body_parts, $part; }
 3553                 last;
 3554             }
 3555         }
 3556     }
 3557     return ( \@body_parts, $msg );
 3558 }
 3559 
 3560 sub dump_long_names {
 3561 
 3562     my @names = @_;
 3563     print STDOUT <<EOM;
 3564 # Command line long names (passed to GetOptions)
 3565 #---------------------------------------------------------------
 3566 # here is a summary of the Getopt codes:
 3567 # <none> does not take an argument
 3568 # =s takes a mandatory string
 3569 # :s takes an optional string
 3570 # =i takes a mandatory integer
 3571 # :i takes an optional integer
 3572 # ! does not take an argument and may be negated
 3573 #  i.e., -foo and -nofoo are allowed
 3574 # a double dash signals the end of the options list
 3575 #
 3576 #---------------------------------------------------------------
 3577 EOM
 3578 
 3579     foreach my $name ( sort @names ) { print STDOUT "$name\n" }
 3580     return;
 3581 }
 3582 
 3583 sub dump_defaults {
 3584     my @defaults = @_;
 3585     print STDOUT "Default command line options:\n";
 3586     foreach my $line ( sort @defaults ) { print STDOUT "$line\n" }
 3587     return;
 3588 }
 3589 
 3590 sub readable_options {
 3591 
 3592     # return options for this run as a string which could be
 3593     # put in a perltidyrc file
 3594     my ( $rOpts, $roption_string ) = @_;
 3595     my %Getopt_flags;
 3596     my $rGetopt_flags    = \%Getopt_flags;
 3597     my $readable_options = "# Final parameter set for this run.\n";
 3598     $readable_options .=
 3599       "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n";
 3600     foreach my $opt ( @{$roption_string} ) {
 3601         my $flag = "";
 3602         if ( $opt =~ /(.*)(!|=.*)$/ ) {
 3603             $opt  = $1;
 3604             $flag = $2;
 3605         }
 3606         if ( defined( $rOpts->{$opt} ) ) {
 3607             $rGetopt_flags->{$opt} = $flag;
 3608         }
 3609     }
 3610     foreach my $key ( sort keys %{$rOpts} ) {
 3611         my $flag   = $rGetopt_flags->{$key};
 3612         my $value  = $rOpts->{$key};
 3613         my $prefix = '--';
 3614         my $suffix = "";
 3615         if ($flag) {
 3616             if ( $flag =~ /^=/ ) {
 3617                 if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' }
 3618                 $suffix = "=" . $value;
 3619             }
 3620             elsif ( $flag =~ /^!/ ) {
 3621                 $prefix .= "no" unless ($value);
 3622             }
 3623             else {
 3624 
 3625                 # shouldn't happen
 3626                 $readable_options .=
 3627                   "# ERROR in dump_options: unrecognized flag $flag for $key\n";
 3628             }
 3629         }
 3630         $readable_options .= $prefix . $key . $suffix . "\n";
 3631     }
 3632     return $readable_options;
 3633 }
 3634 
 3635 sub show_version {
 3636     print STDOUT <<"EOM";
 3637 This is perltidy, v$VERSION 
 3638 
 3639 Copyright 2000-2019, Steve Hancock
 3640 
 3641 Perltidy is free software and may be copied under the terms of the GNU
 3642 General Public License, which is included in the distribution files.
 3643 
 3644 Complete documentation for perltidy can be found using 'man perltidy'
 3645 or on the internet at http://perltidy.sourceforge.net.
 3646 EOM
 3647     return;
 3648 }
 3649 
 3650 sub usage {
 3651 
 3652     print STDOUT <<EOF;
 3653 This is perltidy version $VERSION, a perl script indenter.  Usage:
 3654 
 3655     perltidy [ options ] file1 file2 file3 ...
 3656             (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
 3657     perltidy [ options ] file1 -o outfile
 3658     perltidy [ options ] file1 -st >outfile
 3659     perltidy [ options ] <infile >outfile
 3660 
 3661 Options have short and long forms. Short forms are shown; see
 3662 man pages for long forms.  Note: '=s' indicates a required string,
 3663 and '=n' indicates a required integer.
 3664 
 3665 I/O control
 3666  -h      show this help
 3667  -o=file name of the output file (only if single input file)
 3668  -oext=s change output extension from 'tdy' to s
 3669  -opath=path  change path to be 'path' for output files
 3670  -b      backup original to .bak and modify file in-place
 3671  -bext=s change default backup extension from 'bak' to s
 3672  -q      deactivate error messages (for running under editor)
 3673  -w      include non-critical warning messages in the .ERR error output
 3674  -syn    run perl -c to check syntax (default under unix systems)
 3675  -log    save .LOG file, which has useful diagnostics
 3676  -f      force perltidy to read a binary file
 3677  -g      like -log but writes more detailed .LOG file, for debugging scripts
 3678  -opt    write the set of options actually used to a .LOG file
 3679  -npro   ignore .perltidyrc configuration command file 
 3680  -pro=file   read configuration commands from file instead of .perltidyrc 
 3681  -st     send output to standard output, STDOUT
 3682  -se     send all error output to standard error output, STDERR
 3683  -v      display version number to standard output and quit
 3684 
 3685 Basic Options:
 3686  -i=n    use n columns per indentation level (default n=4)
 3687  -t      tabs: use one tab character per indentation level, not recommended
 3688  -nt     no tabs: use n spaces per indentation level (default)
 3689  -et=n   entab leading whitespace n spaces per tab; not recommended
 3690  -io     "indent only": just do indentation, no other formatting.
 3691  -sil=n  set starting indentation level to n;  use if auto detection fails
 3692  -ole=s  specify output line ending (s=dos or win, mac, unix)
 3693  -ple    keep output line endings same as input (input must be filename)
 3694 
 3695 Whitespace Control
 3696  -fws    freeze whitespace; this disables all whitespace changes
 3697            and disables the following switches:
 3698  -bt=n   sets brace tightness,  n= (0 = loose, 1=default, 2 = tight)
 3699  -bbt    same as -bt but for code block braces; same as -bt if not given
 3700  -bbvt   block braces vertically tight; use with -bl or -bli
 3701  -bbvtl=s  make -bbvt to apply to selected list of block types
 3702  -pt=n   paren tightness (n=0, 1 or 2)
 3703  -sbt=n  square bracket tightness (n=0, 1, or 2)
 3704  -bvt=n  brace vertical tightness, 
 3705          n=(0=open, 1=close unless multiple steps on a line, 2=always close)
 3706  -pvt=n  paren vertical tightness (see -bvt for n)
 3707  -sbvt=n square bracket vertical tightness (see -bvt for n)
 3708  -bvtc=n closing brace vertical tightness: 
 3709          n=(0=open, 1=sometimes close, 2=always close)
 3710  -pvtc=n closing paren vertical tightness, see -bvtc for n.
 3711  -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
 3712  -ci=n   sets continuation indentation=n,  default is n=2 spaces
 3713  -lp     line up parentheses, brackets, and non-BLOCK braces
 3714  -sfs    add space before semicolon in for( ; ; )
 3715  -aws    allow perltidy to add whitespace (default)
 3716  -dws    delete all old non-essential whitespace 
 3717  -icb    indent closing brace of a code block
 3718  -cti=n  closing indentation of paren, square bracket, or non-block brace: 
 3719          n=0 none, =1 align with opening, =2 one full indentation level
 3720  -icp    equivalent to -cti=2
 3721  -wls=s  want space left of tokens in string; i.e. -nwls='+ - * /'
 3722  -wrs=s  want space right of tokens in string;
 3723  -sts    put space before terminal semicolon of a statement
 3724  -sak=s  put space between keywords given in s and '(';
 3725  -nsak=s no space between keywords in s and '('; i.e. -nsak='my our local'
 3726 
 3727 Line Break Control
 3728  -fnl    freeze newlines; this disables all line break changes
 3729             and disables the following switches:
 3730  -anl    add newlines;  ok to introduce new line breaks
 3731  -bbs    add blank line before subs and packages
 3732  -bbc    add blank line before block comments
 3733  -bbb    add blank line between major blocks
 3734  -kbl=n  keep old blank lines? 0=no, 1=some, 2=all
 3735  -mbl=n  maximum consecutive blank lines to output (default=1)
 3736  -ce     cuddled else; use this style: '} else {'
 3737  -cb     cuddled blocks (other than 'if-elsif-else')
 3738  -cbl=s  list of blocks to cuddled, default 'try-catch-finally'
 3739  -dnl    delete old newlines (default)
 3740  -l=n    maximum line length;  default n=80
 3741  -bl     opening brace on new line 
 3742  -sbl    opening sub brace on new line.  value of -bl is used if not given.
 3743  -bli    opening brace on new line and indented
 3744  -bar    opening brace always on right, even for long clauses
 3745  -vt=n   vertical tightness (requires -lp); n controls break after opening
 3746          token: 0=never  1=no break if next line balanced   2=no break
 3747  -vtc=n  vertical tightness of closing container; n controls if closing
 3748          token starts new line: 0=always  1=not unless list  1=never
 3749  -wba=s  want break after tokens in string; i.e. wba=': .'
 3750  -wbb=s  want break before tokens in string
 3751  -wn     weld nested: combines opening and closing tokens when both are adjacent
 3752 
 3753 Following Old Breakpoints
 3754  -kis    keep interior semicolons.  Allows multiple statements per line.
 3755  -boc    break at old comma breaks: turns off all automatic list formatting
 3756  -bol    break at old logical breakpoints: or, and, ||, && (default)
 3757  -bom    break at old method call breakpoints: ->
 3758  -bok    break at old list keyword breakpoints such as map, sort (default)
 3759  -bot    break at old conditional (ternary ?:) operator breakpoints (default)
 3760  -boa    break at old attribute breakpoints 
 3761  -cab=n  break at commas after a comma-arrow (=>):
 3762          n=0 break at all commas after =>
 3763          n=1 stable: break unless this breaks an existing one-line container
 3764          n=2 break only if a one-line container cannot be formed
 3765          n=3 do not treat commas after => specially at all
 3766 
 3767 Comment controls
 3768  -ibc    indent block comments (default)
 3769  -isbc   indent spaced block comments; may indent unless no leading space
 3770  -msc=n  minimum desired spaces to side comment, default 4
 3771  -fpsc=n fix position for side comments; default 0;
 3772  -csc    add or update closing side comments after closing BLOCK brace
 3773  -dcsc   delete closing side comments created by a -csc command
 3774  -cscp=s change closing side comment prefix to be other than '## end'
 3775  -cscl=s change closing side comment to apply to selected list of blocks
 3776  -csci=n minimum number of lines needed to apply a -csc tag, default n=6
 3777  -csct=n maximum number of columns of appended text, default n=20 
 3778  -cscw   causes warning if old side comment is overwritten with -csc
 3779 
 3780  -sbc    use 'static block comments' identified by leading '##' (default)
 3781  -sbcp=s change static block comment identifier to be other than '##'
 3782  -osbc   outdent static block comments
 3783 
 3784  -ssc    use 'static side comments' identified by leading '##' (default)
 3785  -sscp=s change static side comment identifier to be other than '##'
 3786 
 3787 Delete selected text
 3788  -dac    delete all comments AND pod
 3789  -dbc    delete block comments     
 3790  -dsc    delete side comments  
 3791  -dp     delete pod
 3792 
 3793 Send selected text to a '.TEE' file
 3794  -tac    tee all comments AND pod
 3795  -tbc    tee block comments       
 3796  -tsc    tee side comments       
 3797  -tp     tee pod           
 3798 
 3799 Outdenting
 3800  -olq    outdent long quoted strings (default) 
 3801  -olc    outdent a long block comment line
 3802  -ola    outdent statement labels
 3803  -okw    outdent control keywords (redo, next, last, goto, return)
 3804  -okwl=s specify alternative keywords for -okw command
 3805 
 3806 Other controls
 3807  -mft=n  maximum fields per table; default n=40
 3808  -x      do not format lines before hash-bang line (i.e., for VMS)
 3809  -asc    allows perltidy to add a ';' when missing (default)
 3810  -dsm    allows perltidy to delete an unnecessary ';'  (default)
 3811 
 3812 Combinations of other parameters
 3813  -gnu     attempt to follow GNU Coding Standards as applied to perl
 3814  -mangle  remove as many newlines as possible (but keep comments and pods)
 3815  -extrude  insert as many newlines as possible
 3816 
 3817 Dump and die, debugging
 3818  -dop    dump options used in this run to standard output and quit
 3819  -ddf    dump default options to standard output and quit
 3820  -dsn    dump all option short names to standard output and quit
 3821  -dln    dump option long names to standard output and quit
 3822  -dpro   dump whatever configuration file is in effect to standard output
 3823  -dtt    dump all token types to standard output and quit
 3824 
 3825 HTML
 3826  -html write an html file (see 'man perl2web' for many options)
 3827        Note: when -html is used, no indentation or formatting are done.
 3828        Hint: try perltidy -html -css=mystyle.css filename.pl
 3829        and edit mystyle.css to change the appearance of filename.html.
 3830        -nnn gives line numbers
 3831        -pre only writes out <pre>..</pre> code section
 3832        -toc places a table of contents to subs at the top (default)
 3833        -pod passes pod text through pod2html (default)
 3834        -frm write html as a frame (3 files)
 3835        -text=s extra extension for table of contents if -frm, default='toc'
 3836        -sext=s extra extension for file content if -frm, default='src'
 3837 
 3838 A prefix of "n" negates short form toggle switches, and a prefix of "no"
 3839 negates the long forms.  For example, -nasc means don't add missing
 3840 semicolons.  
 3841 
 3842 If you are unable to see this entire text, try "perltidy -h | more"
 3843 For more detailed information, and additional options, try "man perltidy",
 3844 or go to the perltidy home page at http://perltidy.sourceforge.net
 3845 EOF
 3846 
 3847     return;
 3848 }
 3849 
 3850 sub process_this_file {
 3851 
 3852     my ( $tokenizer, $formatter ) = @_;
 3853 
 3854     while ( my $line = $tokenizer->get_line() ) {
 3855         $formatter->write_line($line);
 3856     }
 3857     my $severe_error = $tokenizer->report_tokenization_errors();
 3858     eval { $formatter->finish_formatting($severe_error) };
 3859 
 3860     return;
 3861 }
 3862 
 3863 sub check_syntax {
 3864 
 3865     # Use 'perl -c' to make sure that we did not create bad syntax
 3866     # This is a very good independent check for programming errors
 3867     #
 3868     # Given names of the input and output files, ($istream, $ostream),
 3869     # we do the following:
 3870     # - check syntax of the input file
 3871     # - if bad, all done (could be an incomplete code snippet)
 3872     # - if infile syntax ok, then check syntax of the output file;
 3873     #   - if outfile syntax bad, issue warning; this implies a code bug!
 3874     # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
 3875 
 3876     my ( $istream, $ostream, $logger_object, $rOpts ) = @_;
 3877     my $infile_syntax_ok = 0;
 3878     my $line_of_dashes   = '-' x 42 . "\n";
 3879 
 3880     my $flags = $rOpts->{'perl-syntax-check-flags'};
 3881 
 3882     # be sure we invoke perl with -c
 3883     # note: perl will accept repeated flags like '-c -c'.  It is safest
 3884     # to append another -c than try to find an interior bundled c, as
 3885     # in -Tc, because such a 'c' might be in a quoted string, for example.
 3886     if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
 3887 
 3888     # be sure we invoke perl with -x if requested
 3889     # same comments about repeated parameters applies
 3890     if ( $rOpts->{'look-for-hash-bang'} ) {
 3891         if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
 3892     }
 3893 
 3894     # this shouldn't happen unless a temporary file couldn't be made
 3895     if ( $istream eq '-' ) {
 3896         $logger_object->write_logfile_entry(
 3897             "Cannot run perl -c on STDIN and STDOUT\n");
 3898         return $infile_syntax_ok;
 3899     }
 3900 
 3901     $logger_object->write_logfile_entry(
 3902         "checking input file syntax with perl $flags\n");
 3903 
 3904     # Not all operating systems/shells support redirection of the standard
 3905     # error output.
 3906     my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
 3907 
 3908     my ( $istream_filename, $perl_output ) =
 3909       do_syntax_check( $istream, $flags, $error_redirection );
 3910     $logger_object->write_logfile_entry(
 3911         "Input stream passed to Perl as file $istream_filename\n");
 3912     $logger_object->write_logfile_entry($line_of_dashes);
 3913     $logger_object->write_logfile_entry("$perl_output\n");
 3914 
 3915     if ( $perl_output =~ /syntax\s*OK/ ) {
 3916         $infile_syntax_ok = 1;
 3917         $logger_object->write_logfile_entry($line_of_dashes);
 3918         $logger_object->write_logfile_entry(
 3919             "checking output file syntax with perl $flags ...\n");
 3920         my ( $ostream_filename, $perl_output ) =
 3921           do_syntax_check( $ostream, $flags, $error_redirection );
 3922         $logger_object->write_logfile_entry(
 3923             "Output stream passed to Perl as file $ostream_filename\n");
 3924         $logger_object->write_logfile_entry($line_of_dashes);
 3925         $logger_object->write_logfile_entry("$perl_output\n");
 3926 
 3927         unless ( $perl_output =~ /syntax\s*OK/ ) {
 3928             $logger_object->write_logfile_entry($line_of_dashes);
 3929             $logger_object->warning(
 3930 "The output file has a syntax error when tested with perl $flags $ostream !\n"
 3931             );
 3932             $logger_object->warning(
 3933                 "This implies an error in perltidy; the file $ostream is bad\n"
 3934             );
 3935             $logger_object->report_definite_bug();
 3936 
 3937             # the perl version number will be helpful for diagnosing the problem
 3938             $logger_object->write_logfile_entry( $^V . "\n" );
 3939         }
 3940     }
 3941     else {
 3942 
 3943         # Only warn of perl -c syntax errors.  Other messages,
 3944         # such as missing modules, are too common.  They can be
 3945         # seen by running with perltidy -w
 3946         $logger_object->complain("A syntax check using perl $flags\n");
 3947         $logger_object->complain(
 3948             "for the output in file $istream_filename gives:\n");
 3949         $logger_object->complain($line_of_dashes);
 3950         $logger_object->complain("$perl_output\n");
 3951         $logger_object->complain($line_of_dashes);
 3952         $infile_syntax_ok = -1;
 3953         $logger_object->write_logfile_entry($line_of_dashes);
 3954         $logger_object->write_logfile_entry(
 3955 "The output file will not be checked because of input file problems\n"
 3956         );
 3957     }
 3958     return $infile_syntax_ok;
 3959 }
 3960 
 3961 sub do_syntax_check {
 3962 
 3963     # This should not be called; the syntax check is deactivated
 3964     Die("Unexpected call for syntax check-shouldn't happen\n");
 3965     return;
 3966 }
 3967 
 3968 =pod
 3969 sub do_syntax_check {
 3970     my ( $stream, $flags, $error_redirection ) = @_;
 3971 
 3972     ############################################################
 3973     # This code is not reachable because syntax check is deactivated,
 3974     # but it is retained for reference.
 3975     ############################################################
 3976 
 3977     # We need a named input file for executing perl
 3978     my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream);
 3979 
 3980     # TODO: Need to add name of file to log somewhere
 3981     # otherwise Perl output is hard to read
 3982     if ( !$stream_filename ) { return $stream_filename, "" }
 3983 
 3984     # We have to quote the filename in case it has unusual characters
 3985     # or spaces.  Example: this filename #CM11.pm# gives trouble.
 3986     my $quoted_stream_filename = '"' . $stream_filename . '"';
 3987 
 3988     # Under VMS something like -T will become -t (and an error) so we
 3989     # will put quotes around the flags.  Double quotes seem to work on
 3990     # Unix/Windows/VMS, but this may not work on all systems.  (Single
 3991     # quotes do not work under Windows).  It could become necessary to
 3992     # put double quotes around each flag, such as:  -"c"  -"T"
 3993     # We may eventually need some system-dependent coding here.
 3994     $flags = '"' . $flags . '"';
 3995 
 3996     # now wish for luck...
 3997     my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/; 
 3998 
 3999     if ($is_tmpfile) {
 4000         unlink $stream_filename
 4001           or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n");
 4002     }
 4003     return $stream_filename, $msg;
 4004 }
 4005 =cut
 4006 
 4007 1;
 4008