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