lib/Perl/Tidy.pm

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