"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/lib/Perl/Tidy.pm" (7 Jan 2020, 152343 Bytes) of package /linux/misc/Perl-Tidy-20200110.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: 20191203_vs_20200110.

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