lib/Perl/Tidy.pm

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