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