lib/Perl/Tidy.pm

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