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