lib/Perl/Tidy.pm

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