"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20210717/lib/Perl/Tidy.pm" (14 Jul 2021, 174020 Bytes) of package /linux/misc/Perl-Tidy-20210717.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: 20210402_vs_20210717.

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