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