X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FPerl%2FTidy.pm;h=88f7c43ef002f233fa0bcbbb86f6c7a86f1a3b67;hb=8360fafa7774a02a63bd43854a82f22c335851d9;hp=825b3570b25729a1e8daa53697077659307389ea;hpb=657098da8da16dccd551721ffc180956d8aab7fc;p=perltidy.git diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index 825b357..88f7c43 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -1,9 +1,9 @@ # -###########################################################- +########################################################### # # perltidy - a perl script indenter and formatter # -# Copyright (c) 2000-2019 by Steve Hancock +# Copyright (c) 2000-2022 by Steve Hancock # Distributed under the GPL license agreement; see file COPYING # # This program is free software; you can redistribute it and/or modify @@ -62,6 +62,7 @@ use warnings; use strict; use Exporter; use Carp; +use English qw( -no_match_vars ); use Digest::MD5 qw(md5_hex); use Perl::Tidy::Debugger; use Perl::Tidy::DevNull; @@ -77,15 +78,17 @@ use Perl::Tidy::LineSource; use Perl::Tidy::Logger; use Perl::Tidy::Tokenizer; use Perl::Tidy::VerticalAligner; -local $| = 1; +local $OUTPUT_AUTOFLUSH = 1; + +# DEVEL_MODE can be turned on for extra checking during development +use constant DEVEL_MODE => 0; +use constant EMPTY_STRING => q{}; +use constant SPACE => q{ }; use vars qw{ $VERSION @ISA @EXPORT - $missing_file_spec - $fh_stderr - $rOpts_character_encoding }; @ISA = qw( Exporter ); @@ -93,6 +96,7 @@ use vars qw{ use Cwd; use Encode (); +use Encode::Guess; use IO::File; use File::Basename; use File::Copy; @@ -100,18 +104,42 @@ use File::Temp qw(tempfile); BEGIN { - # Release version is the approximate YYMMDD of the release. + # Release version is the approximate YYYYMMDD of the release. # Development version is (Last Release).(Development Number) # To make the number continually increasing, the Development Number is a 2 - # digit number starting at 01 after a release is continually bumped along - # at significant points during developement. If it ever reaches 99 then the - # Release version must be bumped, and it is probably past time for a - # release anyway. + # digit number starting at 01 after a release. It is continually bumped + # along at significant points during development. If it ever reaches 99 + # then the Release version must be bumped, and it is probably past time for + # a release anyway. + + $VERSION = '20221112'; +} + +sub DESTROY { - $VERSION = '20190601'; + # required to avoid call to AUTOLOAD in some versions of perl } +sub AUTOLOAD { + + # Catch any undefined sub calls so that we are sure to get + # some diagnostic information. This sub should never be called + # except for a programming error. + our $AUTOLOAD; + return if ( $AUTOLOAD =~ /\bDESTROY$/ ); + my ( $pkg, $fname, $lno ) = caller(); + print STDERR <new(@_) }; + $New = sub { Perl::Tidy::IOScalarArray->new( $filename, $mode ) }; } elsif ( $ref eq 'SCALAR' ) { - $New = sub { Perl::Tidy::IOScalar->new(@_) }; + $New = sub { Perl::Tidy::IOScalar->new( $filename, $mode ) }; } else { @@ -162,7 +199,7 @@ sub streamhandle { $New = sub { undef }; confess <new(@_) }; + $New = sub { IO::File->new( $filename, $mode ) }; + } + } + $fh = $New->( $filename, $mode ); + if ( !$fh ) { + + Warn("Couldn't open file:$filename in mode:$mode : $ERRNO\n"); + + } + else { + + # Case 1: handle encoded data + if ($is_encoded_data) { + if ( ref($fh) eq 'IO::File' ) { + ## binmode object call not available in older perl versions + ## $fh->binmode(":raw:encoding(UTF-8)"); + binmode $fh, ":raw:encoding(UTF-8)"; + } + elsif ( $filename eq '-' ) { + binmode STDOUT, ":raw:encoding(UTF-8)"; + } + else { + # shouldn't happen + } + } + + # Case 2: handle unencoded data + else { + if ( ref($fh) eq 'IO::File' ) { binmode $fh } + elsif ( $filename eq '-' ) { binmode STDOUT } + else { } # shouldn't happen } } - $fh = $New->( $filename, $mode ) - or Warn("Couldn't open file:$filename in mode:$mode : $!\n"); return $fh, ( $ref or $filename ); -} +} ## end sub streamhandle sub find_input_line_ending { @@ -224,7 +289,7 @@ sub find_input_line_ending { binmode $fh; my $buf; read( $fh, $buf, 1024 ); - close $fh; + close $fh || return $ending; if ( $buf && $buf =~ /([\012\015]+)/ ) { my $test = $1; @@ -245,41 +310,45 @@ sub find_input_line_ending { else { } return $ending; -} - -sub catfile { +} ## end sub find_input_line_ending - # concatenate a path and file basename - # returns undef in case of error +{ ## begin closure for sub catfile - my @parts = @_; + my $missing_file_spec; BEGIN { - eval { require File::Spec }; - $missing_file_spec = $@; + $missing_file_spec = !eval { require File::Spec; 1 }; } - # use File::Spec if we can - unless ($missing_file_spec) { - return File::Spec->catfile(@parts); - } + sub catfile { - # Perl 5.004 systems may not have File::Spec so we'll make - # a simple try. We assume File::Basename is available. - # return if not successful. - my $name = pop @parts; - my $path = join '/', @parts; - my $test_file = $path . $name; - my ( $test_name, $test_path ) = fileparse($test_file); - return $test_file if ( $test_name eq $name ); - return if ( $^O eq 'VMS' ); + # concatenate a path and file basename + # returns undef in case of error - # this should work at least for Windows and Unix: - $test_file = $path . '/' . $name; - ( $test_name, $test_path ) = fileparse($test_file); - return $test_file if ( $test_name eq $name ); - return; -} + my @parts = @_; + + # use File::Spec if we can + unless ($missing_file_spec) { + return File::Spec->catfile(@parts); + } + + # Perl 5.004 systems may not have File::Spec so we'll make + # a simple try. We assume File::Basename is available. + # return if not successful. + my $name = pop @parts; + my $path = join '/', @parts; + my $test_file = $path . $name; + my ( $test_name, $test_path ) = fileparse($test_file); + return $test_file if ( $test_name eq $name ); + return if ( $OSNAME eq 'VMS' ); + + # this should work at least for Windows and Unix: + $test_file = $path . '/' . $name; + ( $test_name, $test_path ) = fileparse($test_file); + return $test_file if ( $test_name eq $name ); + return; + } ## end sub catfile +} ## end closure for sub catfile # Here is a map of the flow of data from the input source to the output # line sink: @@ -316,6 +385,90 @@ sub catfile { # messages. It writes a .LOG file, which may be saved with a # '-log' or a '-g' flag. +{ #<<< (this side comment avoids excessive indentation in a closure) + +my $Warn_count; +my $fh_stderr; +my $loaded_unicode_gcstring; +my $rstatus; + +# Bump Warn_count only: it is essential to bump the count on all warnings, even +# if no message goes out, so that the correct exit status is set. +sub Warn_count_bump { $Warn_count++; return } + +# Output Warn message only +sub Warn_msg { my $msg = shift; $fh_stderr->print($msg); return } + +# Output Warn message and bump Warn count +sub Warn { my $msg = shift; $fh_stderr->print($msg); $Warn_count++; return } + +sub is_char_mode { + + my ($string) = @_; + + # Returns: + # true if $string is in Perl's internal character mode + # (also called the 'upgraded form', or UTF8=1) + # false if $string is in Perl's internal byte mode + + # This function isolates the call to Perl's internal function + # utf8::is_utf8() which is true for strings represented in an 'upgraded + # form'. It is available after Perl version 5.8. + # See https://perldoc.perl.org/Encode. + # See also comments in Carp.pm and other modules using this function + + return 1 if ( utf8::is_utf8($string) ); + return; +} ## end sub is_char_mode + +my $md5_hex = sub { + my ($buf) = @_; + + # Evaluate the MD5 sum for a string + # Patch for [rt.cpan.org #88020] + # Use utf8::encode since md5_hex() only operates on bytes. + # my $digest = md5_hex( utf8::encode($sink_buffer) ); + + # Note added 20180114: the above patch did not work correctly. I'm not + # sure why. But switching to the method recommended in the Perl 5 + # documentation for Encode worked. According to this we can either use + # $octets = encode_utf8($string) or equivalently + # $octets = encode("utf8",$string) + # and then calculate the checksum. So: + my $octets = Encode::encode( "utf8", $buf ); + my $digest = md5_hex($octets); + return $digest; +}; + +BEGIN { + + # Array index names for $self. + # Do not combine with other BEGIN blocks (c101). + my $i = 0; + use constant { + _actual_output_extension_ => $i++, + _debugfile_stream_ => $i++, + _decoded_input_as_ => $i++, + _destination_stream_ => $i++, + _diagnostics_object_ => $i++, + _display_name_ => $i++, + _file_extension_separator_ => $i++, + _fileroot_ => $i++, + _is_encoded_data_ => $i++, + _length_function_ => $i++, + _line_separator_ => $i++, + _logger_object_ => $i++, + _output_file_ => $i++, + _postfilter_ => $i++, + _prefilter_ => $i++, + _rOpts_ => $i++, + _saw_pbp_ => $i++, + _tabsize_ => $i++, + _teefile_stream_ => $i++, + _user_formatter_ => $i++, + }; +} + sub perltidy { my %input_hash = @_; @@ -326,6 +479,8 @@ sub perltidy { formatter => undef, logfile => undef, errorfile => undef, + teefile => undef, + debugfile => undef, perltidyrc => undef, source => undef, stderr => undef, @@ -339,12 +494,76 @@ sub perltidy { postfilter => undef, ); + # Status information which can be returned for diagnostic purposes. + # NOTE: This is intended only for testing and subject to change. + + # List of "key => value" hash entries: + + # Some relevant user input parameters for convenience: + # opt_format => value of --format: 'tidy', 'html', or 'user' + # opt_encoding => value of -enc flag: 'utf8', 'none', or 'guess' + # opt_encode_output => value of -eos flag: 'eos' or 'neos' + # opt_max_iterations => value of --iterations=n + + # file_count => number of files processed in this call + + # If multiple files are processed, then the following values will be for + # the last file only: + + # input_name => name of the input stream + # output_name => name of the output stream + + # The following two variables refer to Perl's two internal string modes, + # and have the values 0 for 'byte' mode and 1 for 'char' mode: + # char_mode_source => true if source is in 'char' mode. Will be false + # unless we received a source string ref with utf8::is_utf8() set. + # char_mode_used => true if text processed by perltidy in 'char' mode. + # Normally true for text identified as utf8, otherwise false. + + # This tells if Unicode::GCString was used + # gcs_used => true if -gcs and Unicode::GCString found & used + + # These variables tell what utf8 decoding/encoding was done: + # input_decoded_as => non-blank if perltidy decoded the source text + # output_encoded_as => non-blank if perltidy encoded before return + + # These variables are related to iterations and convergence testing: + # iteration_count => number of iterations done + # ( can be from 1 to opt_max_iterations ) + # converged => true if stopped on convergence + # ( can only happen if opt_max_iterations > 1 ) + # blinking => true if stopped on blinking states + # ( i.e., unstable formatting, should not happen ) + + $rstatus = { + + file_count => 0, + opt_format => EMPTY_STRING, + opt_encoding => EMPTY_STRING, + opt_encode_output => EMPTY_STRING, + opt_max_iterations => EMPTY_STRING, + + input_name => EMPTY_STRING, + output_name => EMPTY_STRING, + char_mode_source => 0, + char_mode_used => 0, + input_decoded_as => EMPTY_STRING, + output_encoded_as => EMPTY_STRING, + gcs_used => 0, + iteration_count => 0, + converged => 0, + blinking => 0, + }; + + # Fix for issue git #57 + $Warn_count = 0; + # don't overwrite callers ARGV local @ARGV = @ARGV; local *STDERR = *STDERR; if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) { - local $" = ')('; + local $LIST_SEPARATOR = ')('; my @good_keys = sort keys %defaults; @bad_keys = sort @bad_keys; confess <print($msg); return } + my $self = []; + bless $self, __PACKAGE__; sub Exit { my $flag = shift; @@ -419,6 +641,35 @@ EOM croak "unexpected return to Die"; } + sub Fault { + my ($msg) = @_; + + # This routine is called for errors that really should not occur + # except if there has been a bug introduced by a recent program change. + # Please add comments at calls to Fault to explain why the call + # should not occur, and where to look to fix it. + my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0); + my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1); + my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2); + + my $input_stream_name = $rstatus->{'input_name'}; + $input_stream_name = '(unknown)' unless ($input_stream_name); + Die(<('dump_options'); @@ -432,7 +683,9 @@ EOM unless ( defined($dump_options_type) ) { $dump_options_type = 'perltidyrc'; } - unless ( $dump_options_type =~ /^(perltidyrc|full)$/ ) { + if ( $dump_options_type ne 'perltidyrc' + && $dump_options_type ne 'full' ) + { croak <[_file_extension_separator_] = $dot; - #--------------------------------------------------------------- + #------------------------- # get command line options - #--------------------------------------------------------------- + #------------------------- my ( $rOpts, $config_file, $rraw_options, $roption_string, $rexpansion, $roption_category, $roption_range ) = process_command_line( @@ -518,13 +775,18 @@ EOM $rpending_complaint, $dump_options_type, ); - my $saw_extrude = ( grep { m/^-extrude$/ } @{$rraw_options} ) ? 1 : 0; + # Only filenames should remain in @ARGV + my @Arg_files = @ARGV; + + $self->[_rOpts_] = $rOpts; + my $saw_pbp = - ( grep { m/^-(pbp|perl-best-practices)$/ } @{$rraw_options} ) ? 1 : 0; + grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options}; + $self->[_saw_pbp_] = $saw_pbp; - #--------------------------------------------------------------- + #------------------------------------ # Handle requests to dump information - #--------------------------------------------------------------- + #------------------------------------ # return or exit immediately after all dumps my $quit_now = 0; @@ -534,7 +796,7 @@ EOM $quit_now = 1; foreach my $op ( @{$roption_string} ) { my $opt = $op; - my $flag = ""; + my $flag = EMPTY_STRING; # Examples: # some-option=s @@ -580,11 +842,12 @@ EOM Exit(0); } - #--------------------------------------------------------------- + #---------------------------------------- # check parameters and their interactions - #--------------------------------------------------------------- + #---------------------------------------- my $tabsize = check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ); + $self->[_tabsize_] = $tabsize; if ($user_formatter) { $rOpts->{'format'} = 'user'; @@ -594,76 +857,33 @@ EOM my %default_file_extension = ( tidy => 'tdy', html => 'html', - user => '', + user => EMPTY_STRING, ); - $rOpts_character_encoding = $rOpts->{'character-encoding'}; + $rstatus->{'opt_format'} = $rOpts->{'format'}; + $rstatus->{'opt_max_iterations'} = $rOpts->{'iterations'}; + $rstatus->{'opt_encode_output'} = + $rOpts->{'encode-output-strings'} ? 'eos' : 'neos'; # be sure we have a valid output format unless ( exists $default_file_extension{ $rOpts->{'format'} } ) { - my $formats = join ' ', + my $formats = join SPACE, sort map { "'" . $_ . "'" } keys %default_file_extension; my $fmt = $rOpts->{'format'}; Die("-format='$fmt' but must be one of: $formats\n"); } - my $output_extension = make_extension( $rOpts->{'output-file-extension'}, - $default_file_extension{ $rOpts->{'format'} }, $dot ); - - # If the backup extension contains a / character then the backup should - # be deleted when the -b option is used. On older versions of - # perltidy this will generate an error message due to an illegal - # file name. - # - # A backup file will still be generated but will be deleted - # at the end. If -bext='/' then this extension will be - # the default 'bak'. Otherwise it will be whatever characters - # remains after all '/' characters are removed. For example: - # -bext extension slashes - # '/' bak 1 - # '/delete' delete 1 - # 'delete/' delete 1 - # '/dev/null' devnull 2 (Currently not allowed) - my $bext = $rOpts->{'backup-file-extension'}; - my $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g ); - - # At present only one forward slash is allowed. In the future multiple - # slashes may be allowed to allow for other options - if ( $delete_backup > 1 ) { - Die("-bext=$bext contains more than one '/'\n"); - } - - my $backup_extension = - make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot ); - - my $html_toc_extension = - make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot ); - - my $html_src_extension = - make_extension( $rOpts->{'html-src-extension'}, 'src', $dot ); + my $output_extension = + $self->make_file_extension( $rOpts->{'output-file-extension'}, + $default_file_extension{ $rOpts->{'format'} } ); - # check for -b option; - # silently ignore unless beautify mode - my $in_place_modify = $rOpts->{'backup-and-modify-in-place'} - && $rOpts->{'format'} eq 'tidy'; - - # Turn off -b with warnings in case of conflicts with other options. - # NOTE: Do this silently, without warnings, if there is a source or - # destination stream, or standard output is used. This is because the -b - # flag may have been in a .perltidyrc file and warnings break - # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014. - if ($in_place_modify) { - if ( $rOpts->{'standard-output'} - || $destination_stream - || ref $source_stream - || $rOpts->{'outfile'} - || defined( $rOpts->{'output-path'} ) ) - { - $in_place_modify = 0; - } - } + # get parameters associated with the -b option + my ( $in_place_modify, $backup_extension, $delete_backup ) = + $self->check_in_place_modify( $source_stream, $destination_stream ); Perl::Tidy::Formatter::check_options($rOpts); + Perl::Tidy::Tokenizer::check_options($rOpts); + Perl::Tidy::VerticalAligner::check_options($rOpts); if ( $rOpts->{'format'} eq 'html' ) { Perl::Tidy::HtmlWriter->check_options($rOpts); } @@ -689,14 +909,14 @@ EOM # no filenames should be given if input is from an array if ($source_stream) { - if ( @ARGV > 0 ) { + if ( @Arg_files > 0 ) { Die( "You may not specify any filenames when a source array is given\n" ); } - # we'll stuff the source array into ARGV - unshift( @ARGV, $source_stream ); + # we'll stuff the source array into Arg_files + unshift( @Arg_files, $source_stream ); # No special treatment for source stream which is a filename. # This will enable checks for binary files and other bad stuff. @@ -705,304 +925,1077 @@ EOM # use stdin by default if no source array and no args else { - unshift( @ARGV, '-' ) unless @ARGV; + unshift( @Arg_files, '-' ) unless @Arg_files; } - #--------------------------------------------------------------- - # Ready to go... - # main loop to process all files in argument list - #--------------------------------------------------------------- - my $number_of_files = @ARGV; - my $formatter = undef; - my $tokenizer = undef; + # Flag for loading module Unicode::GCString for evaluating text width: + # undef = ok to use but not yet loaded + # 0 = do not use; failed to load or not wanted + # 1 = successfully loaded and ok to use + # The module is not actually loaded unless/until it is needed + if ( !$rOpts->{'use-unicode-gcstring'} ) { + $loaded_unicode_gcstring = 0; + } + + # Remove duplicate filenames. Otherwise, for example if the user entered + # perltidy -b myfile.pl myfile.pl + # the backup version of the original would be lost. + if ( @Arg_files > 1 ) { + my %seen = (); + @Arg_files = grep { !$seen{$_}++ } @Arg_files; + } # If requested, process in order of increasing file size # This can significantly reduce perl's virtual memory usage during testing. - if ( $number_of_files > 1 && $rOpts->{'file-size-order'} ) { - @ARGV = + if ( @Arg_files > 1 && $rOpts->{'file-size-order'} ) { + @Arg_files = map { $_->[0] } sort { $a->[1] <=> $b->[1] } - map { [ $_, -e $_ ? -s $_ : 0 ] } @ARGV; + map { [ $_, -e $_ ? -s $_ : 0 ] } @Arg_files; } - while ( my $input_file = shift @ARGV ) { - my $fileroot; - my @input_file_stat; + my $logfile_header = make_logfile_header( $rOpts, $config_file, + $rraw_options, $Windows_type, $readable_options, ); - #--------------------------------------------------------------- - # prepare this input stream - #--------------------------------------------------------------- - if ($source_stream) { - $fileroot = "perltidy"; + # Store some values needed by lower level routines + $self->[_diagnostics_object_] = $diagnostics_object; + $self->[_postfilter_] = $postfilter; + $self->[_prefilter_] = $prefilter; + $self->[_user_formatter_] = $user_formatter; - # If the source is from an array or string, then .LOG output - # is only possible if a logfile stream is specified. This prevents - # unexpected perltidy.LOG files. - if ( !defined($logfile_stream) ) { - $logfile_stream = Perl::Tidy::DevNull->new(); - } - } - elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN - $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc - $in_place_modify = 0; - } - else { - $fileroot = $input_file; - unless ( -e $input_file ) { + #-------------------------- + # loop to process all files + #-------------------------- + $self->process_all_files( - # file doesn't exist - check for a file glob - if ( $input_file =~ /([\?\*\[\{])/ ) { + \%input_hash, + \@Arg_files, - # Windows shell may not remove quotes, so do it - my $input_file = $input_file; - if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 } - if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 } - my $pattern = fileglob_to_re($input_file); - ##eval "/$pattern/"; - if ( !$@ && opendir( DIR, './' ) ) { - my @files = - grep { /$pattern/ && !-d $_ } readdir(DIR); - closedir(DIR); - if (@files) { - unshift @ARGV, @files; - next; - } - } - } - Warn("skipping file: '$input_file': no matches found\n"); - next; - } + # filename stuff... + $output_extension, + $forbidden_file_extensions, + $in_place_modify, + $backup_extension, + $delete_backup, - unless ( -f $input_file ) { - Warn("skipping file: $input_file: not a regular file\n"); - next; - } + # logfile stuff... + $logfile_header, + $rpending_complaint, + $rpending_logfile_message, - # As a safety precaution, skip zero length files. - # If for example a source file got clobbered somehow, - # the old .tdy or .bak files might still exist so we - # shouldn't overwrite them with zero length files. - unless ( -s $input_file ) { - Warn("skipping file: $input_file: Zero size\n"); - next; - } + ); - unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) { - Warn( - "skipping file: $input_file: Non-text (override with -f)\n" - ); - next; - } + #----- + # Exit + #----- - # we should have a valid filename now - $fileroot = $input_file; - @input_file_stat = stat($input_file); + # Fix for RT #130297: return a true value if anything was written to the + # standard error output, even non-fatal warning messages, otherwise return + # false. - if ( $^O eq 'VMS' ) { - ( $fileroot, $dot ) = check_vms_filename($fileroot); - } + # These exit codes are returned: + # 0 = perltidy ran to completion with no errors + # 1 = perltidy could not run to completion due to errors + # 2 = perltidy ran to completion with error messages - # add option to change path here - if ( defined( $rOpts->{'output-path'} ) ) { + # Note that if perltidy is run with multiple files, any single file with + # errors or warnings will write a line like + # '## Please see file testing.t.ERR' + # to standard output for each file with errors, so the flag will be true, + # even if only some of the multiple files may have had errors. - my ( $base, $old_path ) = fileparse($fileroot); - my $new_path = $rOpts->{'output-path'}; - unless ( -d $new_path ) { - unless ( mkdir $new_path, 0777 ) { - Die("unable to create directory $new_path: $!\n"); - } - } - my $path = $new_path; - $fileroot = catfile( $path, $base ); - unless ($fileroot) { - Die(<new( $input_file, $rOpts, - $rpending_logfile_message ); - next unless ($source_object); +} ## end sub perltidy - # Prefilters and postfilters: The prefilter is a code reference - # that will be applied to the source before tidying, and the - # postfilter is a code reference to the result before outputting. - if ( - $prefilter - || ( $rOpts_character_encoding - && $rOpts_character_encoding eq 'utf8' ) - ) - { - my $buf = ''; - while ( my $line = $source_object->get_line() ) { - $buf .= $line; - } +sub make_file_extension { - $buf = $prefilter->($buf) if $prefilter; + # Make a file extension, adding any leading '.' if necessary. + # (the '.' may actually be an '_' under VMS). + my ( $self, $extension, $default ) = @_; - if ( $rOpts_character_encoding - && $rOpts_character_encoding eq 'utf8' - && !utf8::is_utf8($buf) ) - { - eval { - $buf = Encode::decode( 'UTF-8', $buf, - Encode::FB_CROAK | Encode::LEAVE_SRC ); - }; - if ($@) { - Warn( -"skipping file: $input_file: Unable to decode source as UTF-8\n" - ); - next; - } - } + # '$extension' is the first choice (usually a user entry) + # '$default' is a backup extension - $source_object = Perl::Tidy::LineSource->new( \$buf, $rOpts, - $rpending_logfile_message ); - } + $extension = EMPTY_STRING unless defined($extension); + $extension =~ s/^\s+//; + $extension =~ s/\s+$//; - # register this file name with the Diagnostics package - $diagnostics_object->set_input_file($input_file) - if $diagnostics_object; + # Use default extension if nothing remains of the first choice + # + if ( length($extension) == 0 ) { + $extension = $default; + $extension = EMPTY_STRING unless defined($extension); + $extension =~ s/^\s+//; + $extension =~ s/\s+$//; + } - #--------------------------------------------------------------- - # prepare the output stream - #--------------------------------------------------------------- - my $output_file = undef; - my $actual_output_extension; + # Only extensions with these leading characters get a '.' + # This rule gives the user some freedom. + if ( $extension =~ /^[a-zA-Z0-9]/ ) { + my $dot = $self->[_file_extension_separator_]; + $extension = $dot . $extension; + } + return $extension; +} ## end sub make_file_extension - if ( $rOpts->{'outfile'} ) { +sub check_in_place_modify { - if ( $number_of_files <= 1 ) { + my ( $self, $source_stream, $destination_stream ) = @_; - if ( $rOpts->{'standard-output'} ) { - my $msg = "You may not use -o and -st together"; - $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp); - Die("$msg\n"); - } - elsif ($destination_stream) { - Die( -"You may not specify a destination array and -o together\n" - ); - } - elsif ( defined( $rOpts->{'output-path'} ) ) { - Die("You may not specify -o and -opath together\n"); - } - elsif ( defined( $rOpts->{'output-file-extension'} ) ) { - Die("You may not specify -o and -oext together\n"); - } - $output_file = $rOpts->{outfile}; + # get parameters associated with the -b option + my $rOpts = $self->[_rOpts_]; - # make sure user gives a file name after -o - if ( $output_file =~ /^-/ ) { - Die("You must specify a valid filename after -o\n"); - } + # check for -b option; + # silently ignore unless beautify mode + my $in_place_modify = $rOpts->{'backup-and-modify-in-place'} + && $rOpts->{'format'} eq 'tidy'; - # do not overwrite input file with -o - if ( @input_file_stat && ( $output_file eq $input_file ) ) { - Die("Use 'perltidy -b $input_file' to modify in-place\n"); - } - } - else { - Die("You may not use -o with more than one input file\n"); - } - } - elsif ( $rOpts->{'standard-output'} ) { - if ($destination_stream) { - my $msg = - "You may not specify a destination array and -st together\n"; - $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp); - Die("$msg\n"); - } - $output_file = '-'; + my ( $backup_extension, $delete_backup ); + + # Turn off -b with warnings in case of conflicts with other options. + # NOTE: Do this silently, without warnings, if there is a source or + # destination stream, or standard output is used. This is because the -b + # flag may have been in a .perltidyrc file and warnings break + # Test::NoWarnings. See email discussion with Merijn Brand 26 Feb 2014. + if ($in_place_modify) { + if ( $rOpts->{'standard-output'} + || $destination_stream + || ref $source_stream + || $rOpts->{'outfile'} + || defined( $rOpts->{'output-path'} ) ) + { + $in_place_modify = 0; + } + } + + if ($in_place_modify) { + + # If the backup extension contains a / character then the backup should + # be deleted when the -b option is used. On older versions of + # perltidy this will generate an error message due to an illegal + # file name. + # + # A backup file will still be generated but will be deleted + # at the end. If -bext='/' then this extension will be + # the default 'bak'. Otherwise it will be whatever characters + # remains after all '/' characters are removed. For example: + # -bext extension slashes + # '/' bak 1 + # '/delete' delete 1 + # 'delete/' delete 1 + # '/dev/null' devnull 2 (Currently not allowed) + my $bext = $rOpts->{'backup-file-extension'}; + $delete_backup = ( $rOpts->{'backup-file-extension'} =~ s/\///g ); + + # At present only one forward slash is allowed. In the future multiple + # slashes may be allowed to allow for other options + if ( $delete_backup > 1 ) { + Die("-bext=$bext contains more than one '/'\n"); + } + + $backup_extension = + $self->make_file_extension( $rOpts->{'backup-file-extension'}, + 'bak' ); + } + + my $backup_method = $rOpts->{'backup-method'}; + if ( defined($backup_method) + && $backup_method ne 'copy' + && $backup_method ne 'move' ) + { + Die( +"Unexpected --backup-method='$backup_method'; must be one of: 'move', 'copy'\n" + ); + } + + return ( $in_place_modify, $backup_extension, $delete_backup ); +} + +sub backup_method_copy { + + my ( $self, $input_file, $output_file, $backup_extension, $delete_backup ) + = @_; + + # Handle the -b (--backup-and-modify-in-place) option with -bm='copy': + # - First copy $input file to $backup_name. + # - Then open input file and rewrite with contents of $output_file + # - Then delete the backup if requested + + # NOTES: + # - Die immediately on any error. + # - $output_file is actually an ARRAY ref + + my $backup_file = $input_file . $backup_extension; + + unless ( -f $input_file ) { + + # no real file to backup .. + # This shouldn't happen because of numerous preliminary checks + Die( + "problem with -b backing up input file '$input_file': not a file\n" + ); + } + + if ( -f $backup_file ) { + unlink($backup_file) + or Die( +"unable to remove previous '$backup_file' for -b option; check permissions: $ERRNO\n" + ); + } + + # Copy input file to backup + File::Copy::copy( $input_file, $backup_file ) + or Die("File::Copy failed trying to backup source: $ERRNO"); + + # set permissions of the backup file to match the input file + my @input_file_stat = stat($input_file); + my $in_place_modify = 1; + $self->set_output_file_permissions( $backup_file, \@input_file_stat, + $in_place_modify ); + + # Open the original input file for writing ... opening with ">" will + # truncate the existing data. + open( my $fout, ">", $input_file ) + || Die( +"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n" + ); + + if ( $self->[_is_encoded_data_] ) { + binmode $fout, ":raw:encoding(UTF-8)"; + } + + # Now copy the formatted output to it.. + + # if formatted output is in an ARRAY ref (normally this is true)... + if ( ref($output_file) eq 'ARRAY' ) { + foreach my $line ( @{$output_file} ) { + $fout->print($line) + or + Die("cannot print to '$input_file' with -b option: $OS_ERROR\n"); + } + } + + # or in a SCALAR ref (less efficient, and only used for testing) + elsif ( ref($output_file) eq 'SCALAR' ) { + foreach my $line ( split /^/, ${$output_file} ) { + $fout->print($line) + or + Die("cannot print to '$input_file' with -b option: $OS_ERROR\n"); + } + } + + # Error if anything else ... + # This can only happen if the output was changed from \@tmp_buff + else { + my $ref = ref($output_file); + Die(<close() + or Die("cannot close '$input_file' with -b option: $OS_ERROR\n"); + + # Set permissions of the output file to match the input file. This is + # necessary even if the inode remains unchanged because suid/sgid bits may + # have been reset. + $self->set_output_file_permissions( $input_file, \@input_file_stat, + $in_place_modify ); + + #--------------------------------------------------------- + # remove the original file for in-place modify as follows: + # $delete_backup=0 never + # $delete_backup=1 only if no errors + # $delete_backup>1 always : NOT ALLOWED, too risky + #--------------------------------------------------------- + if ( $delete_backup && -f $backup_file ) { + + # Currently, $delete_backup may only be 1. But if a future update + # allows a value > 1, then reduce it to 1 if there were warnings. + if ( $delete_backup > 1 + && $self->[_logger_object_]->get_warning_count() ) + { + $delete_backup = 1; + } + + # As an added safety precaution, do not delete the source file + # if its size has dropped from positive to zero, since this + # could indicate a disaster of some kind, including a hardware + # failure. Actually, this could happen if you had a file of + # all comments (or pod) and deleted everything with -dac (-dap) + # for some reason. + if ( !-s $input_file && -s $backup_file && $delete_backup == 1 ) { + Warn( +"output file '$input_file' missing or zero length; original '$backup_file' not deleted\n" + ); + } + else { + unlink($backup_file) + or Die( +"unable to remove backup file '$backup_file' for -b option; check permissions: $ERRNO\n" + ); + } + } + + # Verify that inode is unchanged during development + if (DEVEL_MODE) { + my @output_file_stat = stat($input_file); + my $inode_input = $input_file_stat[1]; + my $inode_output = $output_file_stat[1]; + if ( $inode_input != $inode_output ) { + Fault(<[_is_encoded_data_]; + my ( $fout, $iname ) = + Perl::Tidy::streamhandle( $input_file, 'w', $is_encoded_data ); + if ( !$fout ) { + Die( +"problem re-opening $input_file for write for -b option; check file and directory permissions: $ERRNO\n" + ); + } + + # Now copy the formatted output to it.. + + # if formatted output is in an ARRAY ref ... + if ( ref($output_file) eq 'ARRAY' ) { + foreach my $line ( @{$output_file} ) { + $fout->print($line) + or + Die("cannot print to '$input_file' with -b option: $OS_ERROR\n"); + } + } + + # or in a SCALAR ref (less efficient, for testing only) + elsif ( ref($output_file) eq 'SCALAR' ) { + foreach my $line ( split /^/, ${$output_file} ) { + $fout->print($line) + or + Die("cannot print to '$input_file' with -b option: $OS_ERROR\n"); + } + } + + # Error if anything else ... + # This can only happen if the output was changed from \@tmp_buff + else { + my $ref = ref($output_file); + Die(<close() + or Die("cannot close '$input_file' with -b option: $OS_ERROR\n"); + + # set permissions of the output file to match the input file + my $in_place_modify = 1; + $self->set_output_file_permissions( $input_file, \@input_file_stat, + $in_place_modify ); + + #--------------------------------------------------------- + # remove the original file for in-place modify as follows: + # $delete_backup=0 never + # $delete_backup=1 only if no errors + # $delete_backup>1 always : NOT ALLOWED, too risky + #--------------------------------------------------------- + if ( $delete_backup && -f $backup_name ) { + + # Currently, $delete_backup may only be 1. But if a future update + # allows a value > 1, then reduce it to 1 if there were warnings. + if ( $delete_backup > 1 + && $self->[_logger_object_]->get_warning_count() ) + { + $delete_backup = 1; + } + + # As an added safety precaution, do not delete the source file + # if its size has dropped from positive to zero, since this + # could indicate a disaster of some kind, including a hardware + # failure. Actually, this could happen if you had a file of + # all comments (or pod) and deleted everything with -dac (-dap) + # for some reason. + if ( !-s $input_file && -s $backup_name && $delete_backup == 1 ) { + Warn( +"output file '$input_file' missing or zero length; original '$backup_name' not deleted\n" + ); + } + else { + unlink($backup_name) + or Die( +"unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n" + ); + } + } + + return; + +} ## end sub backup_method_move + +sub set_output_file_permissions { + + my ( $self, $output_file, $rinput_file_stat, $in_place_modify ) = @_; + + # Given: + # $output_file = the file whose permissions we will set + # $rinput_file_stat = the result of stat($input_file) + # $in_place_modify = true if --backup-and-modify-in-place is set + + my ( $mode_i, $uid_i, $gid_i ) = @{$rinput_file_stat}[ 2, 4, 5 ]; + my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ]; + my $input_file_permissions = $mode_i & oct(7777); + my $output_file_permissions = $input_file_permissions; + + #rt128477: avoid inconsistent owner/group and suid/sgid + if ( $uid_i != $uid_o || $gid_i != $gid_o ) { + + # try to change owner and group to match input file if + # in -b mode. Note: chown returns number of files + # successfully changed. + if ( $in_place_modify + && chown( $uid_i, $gid_i, $output_file ) ) + { + # owner/group successfully changed + } + else { + + # owner or group differ: do not copy suid and sgid + $output_file_permissions = $mode_i & oct(777); + if ( $input_file_permissions != $output_file_permissions ) { + Warn( +"Unable to copy setuid and/or setgid bits for output file '$output_file'\n" + ); + } + } + } + + # Mark the output file for rw unless we are in -b mode. + # Explanation: perltidy does not unlink existing output + # files before writing to them, for safety. If a + # designated output file exists and is not writable, + # perltidy will halt. This can prevent a data loss if a + # user accidentally enters "perltidy infile -o + # important_ro_file", or "perltidy infile -st + # >important_ro_file". But it also means that perltidy can + # get locked out of rerunning unless it marks its own + # output files writable. The alternative, of always + # unlinking the designated output file, is less safe and + # not always possible, except in -b mode, where there is an + # assumption that a previous backup can be unlinked even if + # not writable. + if ( !$in_place_modify ) { + $output_file_permissions |= oct(600); + } + + if ( !chmod( $output_file_permissions, $output_file ) ) { + + # couldn't change file permissions + my $operm = sprintf "%04o", $output_file_permissions; + Warn( +"Unable to set permissions for output file '$output_file' to $operm\n" + ); + } + return; +} ## end sub set_output_file_permissions + +sub get_decoded_string_buffer { + my ( $self, $input_file, $display_name, $rpending_logfile_message ) = @_; + + # Decode the input buffer if necessary or requested + + # Given + # $input_file = the input file or stream + # $display_name = its name to use in error messages + + # Return + # $buf = string buffer with input, decoded from utf8 if necessary + # $is_encoded_data = true if $buf is decoded from utf8 + # $decoded_input_as = true if perltidy decoded input buf + # $encoding_log_message = messages for log file, + # $length_function = function to use for measuring string width + + # Return nothing on any error; this is a signal to skip this file + + my $rOpts = $self->[_rOpts_]; + + my $source_object = Perl::Tidy::LineSource->new( + input_file => $input_file, + rOpts => $rOpts, + ); + + # return nothing if error + return unless ($source_object); + + my $buf = EMPTY_STRING; + while ( my $line = $source_object->get_line() ) { + $buf .= $line; + } + + my $encoding_in = EMPTY_STRING; + my $rOpts_character_encoding = $rOpts->{'character-encoding'}; + my $encoding_log_message; + my $decoded_input_as = EMPTY_STRING; + $rstatus->{'char_mode_source'} = 0; + + # Case 1: If Perl is already in a character-oriented mode for this + # string rather than a byte-oriented mode. Normally, this happens if + # the caller has decoded a utf8 string before calling perltidy. But it + # could also happen if the user has done some unusual manipulations of + # the source. In any case, we will not attempt to decode it because + # that could result in an output string in a different mode. + if ( is_char_mode($buf) ) { + $encoding_in = "utf8"; + $rstatus->{'char_mode_source'} = 1; + } + + # Case 2. No input stream encoding requested. This is appropriate + # for single-byte encodings like ascii, latin-1, etc + elsif ( !$rOpts_character_encoding + || $rOpts_character_encoding eq 'none' ) + { + + # nothing to do + } + + # Case 3. guess input stream encoding if requested + elsif ( lc($rOpts_character_encoding) eq 'guess' ) { + + # The guessing strategy is simple: use Encode::Guess to guess + # an encoding. If and only if the guess is utf8, try decoding and + # use it if successful. Otherwise, we proceed assuming the + # characters are encoded as single bytes (same as if 'none' had + # been specified as the encoding). + + # In testing I have found that including additional guess 'suspect' + # encodings sometimes works but can sometimes lead to disaster by + # using an incorrect decoding. The user can always specify a + # specific input encoding. + my $buf_in = $buf; + + my $decoder = guess_encoding( $buf_in, 'utf8' ); + if ( ref($decoder) ) { + $encoding_in = $decoder->name; + if ( $encoding_in ne 'UTF-8' && $encoding_in ne 'utf8' ) { + $encoding_in = EMPTY_STRING; + $buf = $buf_in; + $encoding_log_message .= <decode($buf_in); 1 } ) { + + $encoding_log_message .= <[_is_encoded_data_] = $is_encoded_data; + + # Delete any Byte Order Mark (BOM), which can cause trouble + if ($is_encoded_data) { + $buf =~ s/^\x{FEFF}//; + } + + $rstatus->{'input_name'} = $display_name; + $rstatus->{'opt_encoding'} = $rOpts_character_encoding; + $rstatus->{'char_mode_used'} = $encoding_in ? 1 : 0; + $rstatus->{'input_decoded_as'} = $decoded_input_as; + + # Define the function to determine the display width of character + # strings + my $length_function = sub { return length( $_[0] ) }; + if ($is_encoded_data) { + + # Try to load Unicode::GCString for defining text display width, if + # requested, when the first encoded file is encountered + if ( !defined($loaded_unicode_gcstring) ) { + if ( eval { require Unicode::GCString; 1 } ) { + $loaded_unicode_gcstring = 1; + } + else { + $loaded_unicode_gcstring = 0; + if ( $rOpts->{'use-unicode-gcstring'} ) { + Warn(<new( $_[0] )->columns; + }; + $encoding_log_message .= <{'gcs_used'} = 1; + } + } + return ( + $buf, + $is_encoded_data, + $decoded_input_as, + $encoding_log_message, + $length_function, + + ); +} ## end sub get_decoded_string_buffer + +sub process_all_files { + + my ( + + $self, + $rinput_hash, + $rfiles, + + $output_extension, + $forbidden_file_extensions, + $in_place_modify, + $backup_extension, + $delete_backup, + + $logfile_header, + $rpending_complaint, + $rpending_logfile_message, + + ) = @_; + + # This routine is the main loop to process all files. + # Total formatting is done with these layers of subroutines: + # perltidy - main routine; checks run parameters + # *process_all_files - main loop to process all files; *THIS LAYER + # process_filter_layer - do any pre and post processing; + # process_iteration_layer - handle any iterations on formatting + # process_single_case - solves one formatting problem + + my $rOpts = $self->[_rOpts_]; + my $dot = $self->[_file_extension_separator_]; + my $diagnostics_object = $self->[_diagnostics_object_]; + + my $destination_stream = $rinput_hash->{'destination'}; + my $errorfile_stream = $rinput_hash->{'errorfile'}; + my $logfile_stream = $rinput_hash->{'logfile'}; + my $teefile_stream = $rinput_hash->{'teefile'}; + my $debugfile_stream = $rinput_hash->{'debugfile'}; + my $source_stream = $rinput_hash->{'source'}; + my $stderr_stream = $rinput_hash->{'stderr'}; + + my $number_of_files = @{$rfiles}; + while ( my $input_file = shift @{$rfiles} ) { + + my $fileroot; + my @input_file_stat; + my $display_name; + + #-------------------------- + # prepare this input stream + #-------------------------- + if ($source_stream) { + $fileroot = "perltidy"; + $display_name = ""; + + # If the source is from an array or string, then .LOG output + # is only possible if a logfile stream is specified. This prevents + # unexpected perltidy.LOG files. + if ( !defined($logfile_stream) ) { + $logfile_stream = Perl::Tidy::DevNull->new(); + + # Likewise for .TEE and .DEBUG output + } + if ( !defined($teefile_stream) ) { + $teefile_stream = Perl::Tidy::DevNull->new(); + } + if ( !defined($debugfile_stream) ) { + $debugfile_stream = Perl::Tidy::DevNull->new(); + } + } + elsif ( $input_file eq '-' ) { # '-' indicates input from STDIN + $fileroot = "perltidy"; # root name to use for .ERR, .LOG, etc + $display_name = ""; + $in_place_modify = 0; + } + else { + $fileroot = $input_file; + $display_name = $input_file; + unless ( -e $input_file ) { + + # file doesn't exist - check for a file glob + if ( $input_file =~ /([\?\*\[\{])/ ) { + + # Windows shell may not remove quotes, so do it + my $input_file = $input_file; + if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 } + if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 } + my $pattern = fileglob_to_re($input_file); + my $dh; + if ( opendir( $dh, './' ) ) { + my @files = + grep { /$pattern/ && !-d } readdir($dh); + closedir($dh); + next unless (@files); + unshift @{$rfiles}, @files; + next; + } + } + Warn("skipping file: '$input_file': no matches found\n"); + next; + } + + unless ( -f $input_file ) { + Warn("skipping file: $input_file: not a regular file\n"); + next; + } + + # As a safety precaution, skip zero length files. + # If for example a source file got clobbered somehow, + # the old .tdy or .bak files might still exist so we + # shouldn't overwrite them with zero length files. + unless ( -s $input_file ) { + Warn("skipping file: $input_file: Zero size\n"); + next; + } + + # And avoid formatting extremely large files. Since perltidy reads + # files into memory, trying to process an extremely large file + # could cause system problems. + my $size_in_mb = ( -s $input_file ) / ( 1024 * 1024 ); + if ( $size_in_mb > $rOpts->{'maximum-file-size-mb'} ) { + $size_in_mb = sprintf( "%0.1f", $size_in_mb ); + Warn( +"skipping file: $input_file: size $size_in_mb MB exceeds limit $rOpts->{'maximum-file-size-mb'}; use -mfs=i to change\n" + ); + next; + } + + unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) { + Warn("skipping file: $input_file: Non-text (override with -f)\n" + ); + next; + } + + # Input file must be writable for -b -bm='copy'. We must catch + # this early to prevent encountering trouble after unlinking the + # previous backup. + if ( $in_place_modify && !-w $input_file ) { + my $backup_method = $rOpts->{'backup-method'}; + if ( defined($backup_method) && $backup_method eq 'copy' ) { + Warn +"skipping file '$input_file' for -b option: file reported as non-writable\n"; + next; + } + } + + # we should have a valid filename now + $fileroot = $input_file; + @input_file_stat = stat($input_file); + + if ( $OSNAME eq 'VMS' ) { + ( $fileroot, $dot ) = check_vms_filename($fileroot); + $self->[_file_extension_separator_] = $dot; + } + + # add option to change path here + if ( defined( $rOpts->{'output-path'} ) ) { + + my ( $base, $old_path ) = fileparse($fileroot); + my $new_path = $rOpts->{'output-path'}; + unless ( -d $new_path ) { + unless ( mkdir $new_path, 0777 ) { + Die("unable to create directory $new_path: $ERRNO\n"); + } + } + my $path = $new_path; + $fileroot = catfile( $path, $base ); + unless ($fileroot) { + Die(<get_decoded_string_buffer( $input_file, $display_name, + $rpending_logfile_message ); + + # Skip this file on any error + next if ( !defined($buf) ); + + # Register this file name with the Diagnostics package, if any. + $diagnostics_object->set_input_file($input_file) + if $diagnostics_object; + + # OK: the (possibly decoded) input is now in string $buf. We just need + # to to prepare the output and error logger before formatting it. + + #-------------------------- + # prepare the output stream + #-------------------------- + my $output_file = undef; + my $output_name = EMPTY_STRING; + my $actual_output_extension; + + if ( $rOpts->{'outfile'} ) { + + if ( $number_of_files <= 1 ) { + + if ( $rOpts->{'standard-output'} ) { + my $saw_pbp = $self->[_saw_pbp_]; + my $msg = "You may not use -o and -st together"; + $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp); + Die("$msg\n"); + } + elsif ($destination_stream) { + Die( +"You may not specify a destination array and -o together\n" + ); + } + elsif ( defined( $rOpts->{'output-path'} ) ) { + Die("You may not specify -o and -opath together\n"); + } + elsif ( defined( $rOpts->{'output-file-extension'} ) ) { + Die("You may not specify -o and -oext together\n"); + } + $output_file = $rOpts->{outfile}; + $output_name = $output_file; + + # make sure user gives a file name after -o + if ( $output_file =~ /^-/ ) { + Die("You must specify a valid filename after -o\n"); + } + + # do not overwrite input file with -o + if ( @input_file_stat && ( $output_file eq $input_file ) ) { + Die("Use 'perltidy -b $input_file' to modify in-place\n"); + } + } + else { + Die("You may not use -o with more than one input file\n"); + } + } + elsif ( $rOpts->{'standard-output'} ) { + if ($destination_stream) { + my $saw_pbp = $self->[_saw_pbp_]; + my $msg = + "You may not specify a destination array and -st together\n"; + $msg .= " (-pbp contains -st; see manual)" if ($saw_pbp); + Die("$msg\n"); + } + $output_file = '-'; + $output_name = ""; + + if ( $number_of_files <= 1 ) { + } + else { + Die("You may not use -st with more than one input file\n"); + } + } + elsif ($destination_stream) { - if ( $number_of_files <= 1 ) { - } - else { - Die("You may not use -st with more than one input file\n"); - } - } - elsif ($destination_stream) { $output_file = $destination_stream; + $output_name = ""; } elsif ($source_stream) { # source but no destination goes to stdout $output_file = '-'; + $output_name = ""; } elsif ( $input_file eq '-' ) { $output_file = '-'; + $output_name = ""; } else { if ($in_place_modify) { - $output_file = IO::File->new_tmpfile() - or Die("cannot open temp file for -b option: $!\n"); + + # Send output to a temporary array buffer. This will + # allow efficient copying back to the input by + # sub backup_and_modify_in_place, below. + my @tmp_buff; + $output_file = \@tmp_buff; + $output_name = $display_name; } else { $actual_output_extension = $output_extension; $output_file = $fileroot . $output_extension; + $output_name = $output_file; } } - # the 'sink_object' knows how to write the output file - my $tee_file = $fileroot . $dot . "TEE"; - - my $line_separator = $rOpts->{'output-line-ending'}; - if ( $rOpts->{'preserve-line-endings'} ) { - $line_separator = find_input_line_ending($input_file); - } - - # Eventually all I/O may be done with binmode, but for now it is - # only done when a user requests a particular line separator - # through the -ple or -ole flags - my $binmode = defined($line_separator) - || defined($rOpts_character_encoding); - $line_separator = "\n" unless defined($line_separator); - - my ( $sink_object, $postfilter_buffer ); - if ($postfilter) { - $sink_object = - Perl::Tidy::LineSink->new( \$postfilter_buffer, $tee_file, - $line_separator, $rOpts, $rpending_logfile_message, $binmode ); - } - else { - $sink_object = - Perl::Tidy::LineSink->new( $output_file, $tee_file, - $line_separator, $rOpts, $rpending_logfile_message, $binmode ); - } + $rstatus->{'file_count'} += 1; + $rstatus->{'output_name'} = $output_name; + $rstatus->{'iteration_count'} = 0; + $rstatus->{'converged'} = 0; - #--------------------------------------------------------------- + #------------------------------------------ # initialize the error logger for this file - #--------------------------------------------------------------- + #------------------------------------------ my $warning_file = $fileroot . $dot . "ERR"; if ($errorfile_stream) { $warning_file = $errorfile_stream } my $log_file = $fileroot . $dot . "LOG"; if ($logfile_stream) { $log_file = $logfile_stream } - my $logger_object = - Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file, - $fh_stderr, $saw_extrude ); - write_logfile_header( - $rOpts, $logger_object, $config_file, - $rraw_options, $Windows_type, $readable_options, + my $logger_object = Perl::Tidy::Logger->new( + rOpts => $rOpts, + log_file => $log_file, + warning_file => $warning_file, + fh_stderr => $fh_stderr, + display_name => $display_name, + is_encoded_data => $is_encoded_data, ); + $logger_object->write_logfile_entry($logfile_header); + $logger_object->write_logfile_entry($encoding_log_message) + if $encoding_log_message; + + # Now we can add any pending messages to the log if ( ${$rpending_logfile_message} ) { $logger_object->write_logfile_entry( ${$rpending_logfile_message} ); } @@ -1010,472 +2003,904 @@ EOM $logger_object->complain( ${$rpending_complaint} ); } - #--------------------------------------------------------------- - # initialize the debug object, if any - #--------------------------------------------------------------- - my $debugger_object = undef; - if ( $rOpts->{DEBUG} ) { - $debugger_object = - Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" ); - } - - #--------------------------------------------------------------- - # loop over iterations for one source stream - #--------------------------------------------------------------- - - # We will do a convergence test if 3 or more iterations are allowed. - # It would be pointless for fewer because we have to make at least - # two passes before we can see if we are converged, and the test - # would just slow things down. - my $max_iterations = $rOpts->{'iterations'}; - my $convergence_log_message; - my %saw_md5; - my $do_convergence_test = $max_iterations > 2; - - # Since Digest::MD5 qw(md5_hex) has been in the earliest version of Perl - # we are requiring (5.8), I have commented out this check -##? if ($do_convergence_test) { -##? eval "use Digest::MD5 qw(md5_hex)"; -##? $do_convergence_test = !$@; -##? -##? ### Trying to avoid problems with ancient versions of perl -##? ##eval { my $string = "perltidy"; utf8::encode($string) }; -##? ##$do_convergence_test = $do_convergence_test && !$@; -##? } - - # save objects to allow redirecting output during iterations - my $sink_object_final = $sink_object; - my $debugger_object_final = $debugger_object; - my $logger_object_final = $logger_object; - - foreach my $iter ( 1 .. $max_iterations ) { - - # send output stream to temp buffers until last iteration - my $sink_buffer; - if ( $iter < $max_iterations ) { - $sink_object = - Perl::Tidy::LineSink->new( \$sink_buffer, $tee_file, - $line_separator, $rOpts, $rpending_logfile_message, - $binmode ); + my $line_separator = $rOpts->{'output-line-ending'}; + if ( $rOpts->{'preserve-line-endings'} ) { + $line_separator = find_input_line_ending($input_file); + } + $line_separator = "\n" unless defined($line_separator); + + # additional parameters needed by lower level routines + $self->[_actual_output_extension_] = $actual_output_extension; + $self->[_debugfile_stream_] = $debugfile_stream; + $self->[_decoded_input_as_] = $decoded_input_as; + $self->[_destination_stream_] = $destination_stream; + $self->[_display_name_] = $display_name; + $self->[_fileroot_] = $fileroot; + $self->[_is_encoded_data_] = $is_encoded_data; + $self->[_length_function_] = $length_function; + $self->[_line_separator_] = $line_separator; + $self->[_logger_object_] = $logger_object; + $self->[_output_file_] = $output_file; + $self->[_teefile_stream_] = $teefile_stream; + + #---------------------------------------------------------- + # Do all formatting of this buffer. + # Results will go to the selected output file or streams(s) + #---------------------------------------------------------- + $self->process_filter_layer($buf); + + #-------------------------------------------------- + # Handle the -b option (backup and modify in-place) + #-------------------------------------------------- + if ($in_place_modify) { + + my $backup_method = $rOpts->{'backup-method'}; + + # Option 1, -bm='copy': uses newer version in which original is + # copied to the backup and rewritten; see git #103. + if ( defined($backup_method) && $backup_method eq 'copy' ) { + $self->backup_method_copy( + $input_file, $output_file, + $backup_extension, $delete_backup + ); } + + # Option 2, -bm='move': uses older version, where original is moved + # to the backup and formatted output goes to a new file. else { - $sink_object = $sink_object_final; + $self->backup_method_move( + $input_file, $output_file, + $backup_extension, $delete_backup + ); } + $output_file = $input_file; + } + + #------------------------------------------------------------------- + # Otherwise set output file ownership and permissions if appropriate + #------------------------------------------------------------------- + elsif ( $output_file && -f $output_file && !-l $output_file ) { + if (@input_file_stat) { + if ( $rOpts->{'format'} eq 'tidy' ) { + $self->set_output_file_permissions( $output_file, + \@input_file_stat, $in_place_modify ); + } - # Save logger, debugger output only on pass 1 because: - # (1) line number references must be to the starting - # source, not an intermediate result, and - # (2) we need to know if there are errors so we can stop the - # iterations early if necessary. - if ( $iter > 1 ) { - $debugger_object = undef; - $logger_object = undef; + # else use default permissions for html and any other format } + } - #------------------------------------------------------------ - # create a formatter for this file : html writer or - # pretty printer - #------------------------------------------------------------ + $logger_object->finish() + if $logger_object; + } ## end of main loop to process all files + + return; +} ## end sub process_all_files + +sub process_filter_layer { + + my ( $self, $buf ) = @_; + + # This is the filter layer of processing. + # Do all requested formatting on the string '$buf', including any + # pre- and post-processing with filters. + # Store the results in the selected output file(s) or stream(s). + + # Total formatting is done with these layers of subroutines: + # perltidy - main routine; checks run parameters + # process_all_files - main loop to process all files; + # *process_filter_layer - do any pre and post processing; *THIS LAYER + # process_iteration_layer - handle any iterations on formatting + # process_single_case - solves one formatting problem + + # Data Flow in this layer: + # $buf + # -> optional prefilter operation + # -> [ formatting by sub process_iteration_layer ] + # -> ( optional postfilter_buffer for postfilter, other operations ) + # -> ( optional destination_buffer for encoding ) + # -> final sink_object + + # What is done based on format type: + # utf8 decoding is done for all format types + # prefiltering is applied to all format types + # - because it may be needed to get through the tokenizer + # postfiltering is only done for format='tidy' + # - might cause problems operating on html text + # encoding of decoded output is only done for format='tidy' + # - because html does its own encoding; user formatter does what it wants + + my $rOpts = $self->[_rOpts_]; + my $is_encoded_data = $self->[_is_encoded_data_]; + my $logger_object = $self->[_logger_object_]; + my $output_file = $self->[_output_file_]; + my $user_formatter = $self->[_user_formatter_]; + my $destination_stream = $self->[_destination_stream_]; + my $prefilter = $self->[_prefilter_]; + my $postfilter = $self->[_postfilter_]; + my $decoded_input_as = $self->[_decoded_input_as_]; + my $line_separator = $self->[_line_separator_]; + + my $remove_terminal_newline = + !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/; + + # vars for postfilter, if used + my $use_postfilter_buffer; + my $postfilter_buffer; + + # vars for destination buffer, if used + my $destination_buffer; + my $use_destination_buffer; + my $encode_destination_buffer; + + # vars for iterations, if done + my $sink_object; + + # vars for checking assertions, if needed + my $digest_input = 0; + my $saved_input_buf; + + my $ref_destination_stream = ref($destination_stream); + + # Setup vars for postfilter, destination buffer, assertions and sink object + # if needed. These are only used for 'tidy' formatting. + if ( $rOpts->{'format'} eq 'tidy' ) { + + # evaluate MD5 sum of input file for assert tests before any prefilter + if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) { + $digest_input = $md5_hex->($buf); + $saved_input_buf = $buf; + } - # we have to delete any old formatter because, for safety, - # the formatter will check to see that there is only one. - $formatter = undef; + #----------------------- + # Setup postfilter buffer + #----------------------- + # If we need access to the output for filtering or checking assertions + # before writing to its ultimate destination, then we will send it + # to a temporary buffer. The variables are: + # $postfilter_buffer = the buffer to capture the output + # $use_postfilter_buffer = is a postfilter buffer used? + # These are used below, just after iterations are made. + $use_postfilter_buffer = + $postfilter + || $remove_terminal_newline + || $rOpts->{'assert-tidy'} + || $rOpts->{'assert-untidy'}; + + #------------------------- + # Setup destination_buffer + #------------------------- + # If the final output destination is not a file, then we might need to + # encode the result at the end of processing. So in this case we will + # send the output to a temporary buffer. + # The key variables are: + # $destination_buffer - receives the formatted output + # $use_destination_buffer - is $destination_buffer used? + # $encode_destination_buffer - encode $destination_buffer? + # These are used by sub 'copy_buffer_to_destination', below + + if ($ref_destination_stream) { + $use_destination_buffer = 1; + $output_file = \$destination_buffer; + $self->[_output_file_] = $output_file; + + # Strings and arrays use special encoding rules + if ( $ref_destination_stream eq 'SCALAR' + || $ref_destination_stream eq 'ARRAY' ) + { + $encode_destination_buffer = + $rOpts->{'encode-output-strings'} && $decoded_input_as; + } - if ($user_formatter) { - $formatter = $user_formatter; + # An object with a print method will use file encoding rules + elsif ( $ref_destination_stream->can('print') ) { + $encode_destination_buffer = $is_encoded_data; + } + else { + confess <{'format'} eq 'html' ) { - $formatter = - Perl::Tidy::HtmlWriter->new( $fileroot, $output_file, - $actual_output_extension, $html_toc_extension, - $html_src_extension ); + } + + #------------------------------------------- + # Make a sink object for the iteration phase + #------------------------------------------- + $sink_object = Perl::Tidy::LineSink->new( + output_file => $use_postfilter_buffer + ? \$postfilter_buffer + : $output_file, + line_separator => $line_separator, + is_encoded_data => $is_encoded_data, + ); + } + + #----------------------------------------------------------------------- + # Apply any prefilter. The prefilter is a code reference that will be + # applied to the source before tokenizing. Note that we are doing this + # for all format types ('tidy', 'html', 'user') because it may be needed + # to avoid tokenization errors. + #----------------------------------------------------------------------- + $buf = $prefilter->($buf) if $prefilter; + + #---------------------------------------------------------------------- + # Format contents of string '$buf', iterating if requested. + # For 'tidy', formatted result will be written to '$sink_object' + # For 'html' and 'user', result goes directly to its ultimate destination. + #---------------------------------------------------------------------- + $self->process_iteration_layer( $buf, $sink_object ); + + #-------------------------------- + # Do postfilter buffer processing + #-------------------------------- + if ($use_postfilter_buffer) { + + my $sink_object_post = Perl::Tidy::LineSink->new( + output_file => $output_file, + line_separator => $line_separator, + is_encoded_data => $is_encoded_data, + ); + + #---------------------------------------------------------------------- + # Apply any postfilter. The postfilter is a code reference that will be + # applied to the source after tidying. + #---------------------------------------------------------------------- + my $buf_post = + $postfilter + ? $postfilter->($postfilter_buffer) + : $postfilter_buffer; + + # Check if file changed if requested, but only after any postfilter + if ( $rOpts->{'assert-tidy'} ) { + my $digest_output = $md5_hex->($buf_post); + if ( $digest_output ne $digest_input ) { + my $diff_msg = + compare_string_buffers( $saved_input_buf, $buf_post, + $is_encoded_data ); + $logger_object->warning(<interrupt_logfile(); + $logger_object->warning( $diff_msg . "\n" ); + $logger_object->resume_logfile(); } - elsif ( $rOpts->{'format'} eq 'tidy' ) { - $formatter = Perl::Tidy::Formatter->new( - logger_object => $logger_object, - diagnostics_object => $diagnostics_object, - sink_object => $sink_object, + } + + if ( $rOpts->{'assert-untidy'} ) { + my $digest_output = $md5_hex->($buf_post); + if ( $digest_output eq $digest_input ) { + $logger_object->warning( +"assertion failure: '--assert-untidy' is set but output equals input\n" ); } - else { - Die("I don't know how to do -format=$rOpts->{'format'}\n"); + } + + my $source_object = Perl::Tidy::LineSource->new( + input_file => \$buf_post, + rOpts => $rOpts, + ); + + # Copy the filtered buffer to the final destination + if ( !$remove_terminal_newline ) { + while ( my $line = $source_object->get_line() ) { + $sink_object_post->write_line($line); } + } + else { - unless ($formatter) { - Die("Unable to continue with $rOpts->{'format'} formatting\n"); + # Copy the filtered buffer but remove the newline char from the + # final line + my $line; + while ( my $next_line = $source_object->get_line() ) { + $sink_object_post->write_line($line) if ($line); + $line = $next_line; + } + if ($line) { + $sink_object_post->set_line_separator(undef); + chomp $line; + $sink_object_post->write_line($line); } + } + $sink_object_post->close_output_file(); + $source_object->close_input_file(); + } + + #-------------------------------------------------------- + # Do destination buffer processing, encoding if required. + #-------------------------------------------------------- + if ($use_destination_buffer) { + $self->copy_buffer_to_destination( $destination_buffer, + $destination_stream, $encode_destination_buffer ); + } + else { + + # output went to a file in 'tidy' mode... + if ( $is_encoded_data && $rOpts->{'format'} eq 'tidy' ) { + $rstatus->{'output_encoded_as'} = 'UTF-8'; + } + } + + # The final formatted result should now be in the selected output file(s) + # or stream(s). + return; + +} ## end sub process_filter_layer + +sub process_iteration_layer { + + my ( $self, $buf, $sink_object ) = @_; + + # This is the iteration layer of processing. + # Do all formatting, iterating if requested, on the source string $buf. + # Output depends on format type: + # For 'tidy' formatting, output goes to sink object + # For 'html' formatting, output goes to the ultimate destination + # For 'user' formatting, user formatter handles output + + # Total formatting is done with these layers of subroutines: + # perltidy - main routine; checks run parameters + # process_all_files - main loop to process all files; + # process_filter_layer - do any pre and post processing + # *process_iteration_layer - do any iterations on formatting; *THIS LAYER + # process_single_case - solves one formatting problem + + # Data Flow in this layer: + # $buf -> [ loop over iterations ] -> $sink_object + + # Only 'tidy' formatting can use multiple iterations. + + my $diagnostics_object = $self->[_diagnostics_object_]; + my $display_name = $self->[_display_name_]; + my $fileroot = $self->[_fileroot_]; + my $is_encoded_data = $self->[_is_encoded_data_]; + my $length_function = $self->[_length_function_]; + my $line_separator = $self->[_line_separator_]; + my $logger_object = $self->[_logger_object_]; + my $rOpts = $self->[_rOpts_]; + my $tabsize = $self->[_tabsize_]; + my $user_formatter = $self->[_user_formatter_]; + + # create a source object for the buffer + my $source_object = Perl::Tidy::LineSource->new( + input_file => \$buf, + rOpts => $rOpts, + ); - #--------------------------------------------------------------- - # create the tokenizer for this file - #--------------------------------------------------------------- - $tokenizer = undef; # must destroy old tokenizer - $tokenizer = Perl::Tidy::Tokenizer->new( - source_object => $source_object, + # make a debugger object if requested + my $debugger_object; + if ( $rOpts->{DEBUG} ) { + my $debug_file = $self->[_debugfile_stream_] + || $fileroot . $self->make_file_extension('DEBUG'); + $debugger_object = + Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data ); + } + + # make a tee file handle if requested + my $fh_tee; + if ( $rOpts->{'tee-pod'} + || $rOpts->{'tee-block-comments'} + || $rOpts->{'tee-side-comments'} ) + { + my $tee_file = $self->[_teefile_stream_] + || $fileroot . $self->make_file_extension('TEE'); + ( $fh_tee, my $tee_filename ) = + Perl::Tidy::streamhandle( $tee_file, 'w', $is_encoded_data ); + if ( !$fh_tee ) { + Warn("couldn't open TEE file $tee_file: $ERRNO\n"); + } + } + + # vars for iterations and convergence test + my $max_iterations = 1; + my $convergence_log_message; + my $do_convergence_test; + my %saw_md5; + + # Only 'tidy' formatting can use multiple iterations + if ( $rOpts->{'format'} eq 'tidy' ) { + + # check iteration count and quietly fix if necessary: + # - iterations option only applies to code beautification mode + # - the convergence check should stop most runs on iteration 2, and + # virtually all on iteration 3. But we'll allow up to 6. + $max_iterations = $rOpts->{'iterations'}; + if ( !defined($max_iterations) + || $max_iterations <= 0 ) + { + $max_iterations = 1; + } + elsif ( $max_iterations > 6 ) { + $max_iterations = 6; + } + + # get starting MD5 sum for convergence test + if ( $max_iterations > 1 ) { + $do_convergence_test = 1; + my $digest = $md5_hex->($buf); + $saw_md5{$digest} = 0; + } + } + + # save objects to allow redirecting output during iterations + my $sink_object_final = $sink_object; + my $logger_object_final = $logger_object; + my $iteration_of_formatter_convergence; + + #--------------------- + # Loop over iterations + #--------------------- + foreach my $iter ( 1 .. $max_iterations ) { + + $rstatus->{'iteration_count'} += 1; + + # send output stream to temp buffers until last iteration + my $sink_buffer; + if ( $iter < $max_iterations ) { + $sink_object = Perl::Tidy::LineSink->new( + output_file => \$sink_buffer, + line_separator => $line_separator, + is_encoded_data => $is_encoded_data, + ); + } + else { + $sink_object = $sink_object_final; + } + + # Save logger, debugger and tee output only on pass 1 because: + # (1) line number references must be to the starting + # source, not an intermediate result, and + # (2) we need to know if there are errors so we can stop the + # iterations early if necessary. + # (3) the tee option only works on first pass if comments are also + # being deleted. + if ( $iter > 1 ) { + + $debugger_object->close_debug_file() if ($debugger_object); + $fh_tee->close() if ($fh_tee); + + $debugger_object = undef; + $logger_object = undef; + $fh_tee = undef; + } + + #--------------------------------- + # create a formatter for this file + #--------------------------------- + + my $formatter; + + if ($user_formatter) { + $formatter = $user_formatter; + } + elsif ( $rOpts->{'format'} eq 'html' ) { + + my $html_toc_extension = + $self->make_file_extension( $rOpts->{'html-toc-extension'}, + 'toc' ); + + my $html_src_extension = + $self->make_file_extension( $rOpts->{'html-src-extension'}, + 'src' ); + + $formatter = Perl::Tidy::HtmlWriter->new( + input_file => $fileroot, + html_file => $self->[_output_file_], + extension => $self->[_actual_output_extension_], + html_toc_extension => $html_toc_extension, + html_src_extension => $html_src_extension, + ); + } + elsif ( $rOpts->{'format'} eq 'tidy' ) { + $formatter = Perl::Tidy::Formatter->new( logger_object => $logger_object, - debugger_object => $debugger_object, diagnostics_object => $diagnostics_object, - tabsize => $tabsize, - - starting_level => $rOpts->{'starting-indentation-level'}, - indent_columns => $rOpts->{'indent-columns'}, - look_for_hash_bang => $rOpts->{'look-for-hash-bang'}, - look_for_autoloader => $rOpts->{'look-for-autoloader'}, - look_for_selfloader => $rOpts->{'look-for-selfloader'}, - trim_qw => $rOpts->{'trim-qw'}, - extended_syntax => $rOpts->{'extended-syntax'}, - - continuation_indentation => - $rOpts->{'continuation-indentation'}, - outdent_labels => $rOpts->{'outdent-labels'}, + sink_object => $sink_object, + length_function => $length_function, + is_encoded_data => $is_encoded_data, + fh_tee => $fh_tee, + ); + } + else { + Die("I don't know how to do -format=$rOpts->{'format'}\n"); + } + + unless ($formatter) { + Die("Unable to continue with $rOpts->{'format'} formatting\n"); + } + + #----------------------------------- + # create the tokenizer for this file + #----------------------------------- + my $tokenizer = Perl::Tidy::Tokenizer->new( + source_object => $source_object, + logger_object => $logger_object, + debugger_object => $debugger_object, + diagnostics_object => $diagnostics_object, + tabsize => $tabsize, + rOpts => $rOpts, + + starting_level => $rOpts->{'starting-indentation-level'}, + indent_columns => $rOpts->{'indent-columns'}, + look_for_hash_bang => $rOpts->{'look-for-hash-bang'}, + look_for_autoloader => $rOpts->{'look-for-autoloader'}, + look_for_selfloader => $rOpts->{'look-for-selfloader'}, + trim_qw => $rOpts->{'trim-qw'}, + extended_syntax => $rOpts->{'extended-syntax'}, + + continuation_indentation => $rOpts->{'continuation-indentation'}, + outdent_labels => $rOpts->{'outdent-labels'}, + ); + + #--------------------------------- + # do processing for this iteration + #--------------------------------- + process_single_case( $tokenizer, $formatter ); + + #----------------------------------------- + # close the input source and report errors + #----------------------------------------- + $source_object->close_input_file(); + + # see if the formatter is converged + if ( $max_iterations > 1 + && !defined($iteration_of_formatter_convergence) + && $formatter->can('get_convergence_check') ) + { + if ( $formatter->get_convergence_check() ) { + $iteration_of_formatter_convergence = $iter; + $rstatus->{'converged'} = 1; + } + } + + # line source for next iteration (if any) comes from the current + # temporary output buffer + if ( $iter < $max_iterations ) { + + $sink_object->close_output_file(); + $source_object = Perl::Tidy::LineSource->new( + input_file => \$sink_buffer, + rOpts => $rOpts, ); - #--------------------------------------------------------------- - # now we can do it - #--------------------------------------------------------------- - process_this_file( $tokenizer, $formatter ); - - #--------------------------------------------------------------- - # close the input source and report errors - #--------------------------------------------------------------- - $source_object->close_input_file(); - - # line source for next iteration (if any) comes from the current - # temporary output buffer - if ( $iter < $max_iterations ) { - - $sink_object->close_output_file(); - $source_object = - Perl::Tidy::LineSource->new( \$sink_buffer, $rOpts, - $rpending_logfile_message ); - - # stop iterations if errors or converged - #my $stop_now = $logger_object->{_warning_count}; - my $stop_now = $tokenizer->report_tokenization_errors(); - if ($stop_now) { - $convergence_log_message = <report_tokenization_errors(); + $stop_now ||= $tokenizer->get_unexpected_error_count(); + my $stopping_on_error = $stop_now; + if ($stop_now) { + $convergence_log_message = <($sink_buffer); + if ( !defined( $saw_md5{$digest} ) ) { + $saw_md5{$digest} = $iter; + } + else { - # Blinking (oscillating) between two stable - # end states. This has happened in the past - # but at present there are no known instances. - $convergence_log_message = <{'blinking'} = 1; + $convergence_log_message = <write_diagnostics( - $convergence_log_message) - if $diagnostics_object; - } - else { - $convergence_log_message = <write_diagnostics( + $convergence_log_message) + if $diagnostics_object; + +# Uncomment to search for blinking states +# Warn( "$display_name: blinking; iter $iter same as for $saw_md5{$digest}\n" ); + + } + else { + $convergence_log_message = <write_diagnostics( - $convergence_log_message) - if $diagnostics_object && $iterm > 2; - } + $diagnostics_object->write_diagnostics( + $convergence_log_message) + if $diagnostics_object && $iterm > 2; + $rstatus->{'converged'} = 1; } - } ## end if ($do_convergence_test) + } + } ## end if ($do_convergence_test) + + if ($stop_now) { + + if (DEVEL_MODE) { + + if ( defined($iteration_of_formatter_convergence) ) { - if ($stop_now) { + # This message cannot appear unless the formatter + # convergence test above is temporarily skipped for + # testing. + if ( $iteration_of_formatter_convergence < $iter - 1 ) { + print STDERR +"STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\n"; + } + } + elsif ( !$stopping_on_error ) { + print STDERR +"STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n"; + } + } - # we are stopping the iterations early; - # copy the output stream to its final destination - $sink_object = $sink_object_final; - while ( my $line = $source_object->get_line() ) { - $sink_object->write_line($line); - } - $source_object->close_input_file(); - last; + # we are stopping the iterations early; + # copy the output stream to its final destination + $sink_object = $sink_object_final; + while ( my $line = $source_object->get_line() ) { + $sink_object->write_line($line); } - } ## end if ( $iter < $max_iterations) - } # end loop over iterations for one source file + $source_object->close_input_file(); + last; + } + } ## end if ( $iter < $max_iterations) + } ## end loop over iterations for one source file - # restore objects which have been temporarily undefined - # for second and higher iterations - $debugger_object = $debugger_object_final; - $logger_object = $logger_object_final; + $sink_object->close_output_file() if $sink_object; + $debugger_object->close_debug_file() if $debugger_object; + $fh_tee->close() if $fh_tee; - $logger_object->write_logfile_entry($convergence_log_message) - if $convergence_log_message; + # leave logger object open for additional messages + $logger_object = $logger_object_final; + $logger_object->write_logfile_entry($convergence_log_message) + if $convergence_log_message; - #--------------------------------------------------------------- - # Perform any postfilter operation - #--------------------------------------------------------------- - if ($postfilter) { - $sink_object->close_output_file(); - $sink_object = - Perl::Tidy::LineSink->new( $output_file, $tee_file, - $line_separator, $rOpts, $rpending_logfile_message, $binmode ); - my $buf = $postfilter->($postfilter_buffer); - $source_object = - Perl::Tidy::LineSource->new( \$buf, $rOpts, - $rpending_logfile_message ); - while ( my $line = $source_object->get_line() ) { - $sink_object->write_line($line); - } - $source_object->close_input_file(); - } + return; - # Save names of the input and output files for syntax check - my $ifname = $input_file; - my $ofname = $output_file; +} ## end sub process_iteration_layer - #--------------------------------------------------------------- - # handle the -b option (backup and modify in-place) - #--------------------------------------------------------------- - if ($in_place_modify) { - unless ( -f $input_file ) { +sub process_single_case { - # oh, oh, no real file to backup .. - # shouldn't happen because of numerous preliminary checks - Die( -"problem with -b backing up input file '$input_file': not a file\n" - ); - } - my $backup_name = $input_file . $backup_extension; - if ( -f $backup_name ) { - unlink($backup_name) - or Die( -"unable to remove previous '$backup_name' for -b option; check permissions: $!\n" - ); - } + # run the formatter on a single defined case + my ( $tokenizer, $formatter ) = @_; - # backup the input file - # we use copy for symlinks, move for regular files - if ( -l $input_file ) { - File::Copy::copy( $input_file, $backup_name ) - or Die("File::Copy failed trying to backup source: $!"); - } - else { - rename( $input_file, $backup_name ) - or Die( -"problem renaming $input_file to $backup_name for -b option: $!\n" - ); - } - $ifname = $backup_name; - - # copy the output to the original input file - # NOTE: it would be nice to just close $output_file and use - # File::Copy::copy here, but in this case $output_file is the - # handle of an open nameless temporary file so we would lose - # everything if we closed it. - seek( $output_file, 0, 0 ) - or Die("unable to rewind a temporary file for -b option: $!\n"); - my $fout = IO::File->new("> $input_file") - or Die( -"problem re-opening $input_file for write for -b option; check file and directory permissions: $!\n" - ); - if ($binmode) { - if ( $rOpts->{'character-encoding'} - && $rOpts->{'character-encoding'} eq 'utf8' ) - { - binmode $fout, ":raw:encoding(UTF-8)"; - } - else { binmode $fout } - } - my $line; - while ( $line = $output_file->getline() ) { - $fout->print($line); - } - $fout->close(); - $output_file = $input_file; - $ofname = $input_file; - } + # Total formatting is done with these layers of subroutines: + # perltidy - main routine; checks run parameters + # process_all_files - main loop to process all files; + # process_filter_layer - do any pre and post processing; + # process_iteration_layer - do any iterations on formatting + # *process_single_case - solve one formatting problem; *THIS LAYER - #--------------------------------------------------------------- - # clean up and report errors - #--------------------------------------------------------------- - $sink_object->close_output_file() if $sink_object; - $debugger_object->close_debug_file() if $debugger_object; + while ( my $line = $tokenizer->get_line() ) { + $formatter->write_line($line); + } + my $severe_error = $tokenizer->report_tokenization_errors(); - # set output file permissions - if ( $output_file && -f $output_file && !-l $output_file ) { - if (@input_file_stat) { + # user-defined formatters are possible, and may not have a + # sub 'finish_formatting', so we have to check + $formatter->finish_formatting($severe_error) + if $formatter->can('finish_formatting'); - # Set file ownership and permissions - if ( $rOpts->{'format'} eq 'tidy' ) { - my ( $mode_i, $uid_i, $gid_i ) = - @input_file_stat[ 2, 4, 5 ]; - my ( $uid_o, $gid_o ) = ( stat($output_file) )[ 4, 5 ]; - my $input_file_permissions = $mode_i & oct(7777); - my $output_file_permissions = $input_file_permissions; - - #rt128477: avoid inconsistent owner/group and suid/sgid - if ( $uid_i != $uid_o || $gid_i != $gid_o ) { - - # try to change owner and group to match input file if in -b mode - # note: chown returns number of files successfully changed - if ( $in_place_modify - && chown( $uid_i, $gid_i, $output_file ) ) - { - # owner/group successfully changed - } - else { + return; +} ## end sub process_single_case - # owner or group differ: do not copy suid and sgid - $output_file_permissions = $mode_i & oct(777); - if ( $input_file_permissions != - $output_file_permissions ) - { - Warn( -"Unable to copy setuid and/or setgid bits for output file '$output_file'\n" - ); - } - } - } +sub copy_buffer_to_destination { - # Make the output file for rw unless we are in -b mode. - # Explanation: perltidy does not unlink existing output - # files before writing to them, for safety. If a - # designated output file exists and is not writable, - # perltidy will halt. This can prevent a data loss if a - # user accidentally enters "perltidy infile -o - # important_ro_file", or "perltidy infile -st - # >important_ro_file". But it also means that perltidy can - # get locked out of rerunning unless it marks its own - # output files writable. The alternative, of always - # unlinking the designated output file, is less safe and - # not always possible, except in -b mode, where there is an - # assumption that a previous backup can be unlinked even if - # not writable. - if ( !$in_place_modify ) { - $output_file_permissions |= oct(600); - } + my ( $self, $destination_buffer, $destination_stream, + $encode_destination_buffer ) + = @_; - if ( !chmod( $output_file_permissions, $output_file ) ) { + # Copy $destination_buffer to the final $destination_stream, + # encoding if the flag $encode_destination_buffer is true. - # couldn't change file permissions - my $operm = sprintf "%04o", $output_file_permissions; - Warn( -"Unable to set permissions for output file '$output_file' to $operm\n" - ); - } - } + # Data Flow: + # $destination_buffer -> [ encode? ] -> $destination_stream - # else use default permissions for html and any other format + $rstatus->{'output_encoded_as'} = EMPTY_STRING; + + if ($encode_destination_buffer) { + my $encoded_buffer; + if ( + !eval { + $encoded_buffer = + Encode::encode( "UTF-8", $destination_buffer, + Encode::FB_CROAK | Encode::LEAVE_SRC ); + 1; } + ) + { + + Warn( +"Error attempting to encode output string ref; encoding not done\n" + ); + } + else { + $destination_buffer = $encoded_buffer; + $rstatus->{'output_encoded_as'} = 'UTF-8'; } + } - #--------------------------------------------------------------- - # Do syntax check if requested and possible - #--------------------------------------------------------------- - my $infile_syntax_ok = 0; # -1 no 0=don't know 1 yes - if ( $logger_object - && $rOpts->{'check-syntax'} - && $ifname - && $ofname ) - { - $infile_syntax_ok = - check_syntax( $ifname, $ofname, $logger_object, $rOpts ); - } - - #--------------------------------------------------------------- - # remove the original file for in-place modify as follows: - # $delete_backup=0 never - # $delete_backup=1 only if no errors - # $delete_backup>1 always : NOT ALLOWED, too risky, see above - #--------------------------------------------------------------- - if ( $in_place_modify - && $delete_backup - && -f $ifname - && ( $delete_backup > 1 || !$logger_object->{_warning_count} ) ) - { + # Send data for SCALAR, ARRAY & OBJ refs to its final destination + if ( ref($destination_stream) eq 'SCALAR' ) { + ${$destination_stream} = $destination_buffer; + } + elsif ($destination_buffer) { + my @lines = split /^/, $destination_buffer; + if ( ref($destination_stream) eq 'ARRAY' ) { + @{$destination_stream} = @lines; + } - # As an added safety precaution, do not delete the source file - # if its size has dropped from positive to zero, since this - # could indicate a disaster of some kind, including a hardware - # failure. Actually, this could happen if you had a file of - # all comments (or pod) and deleted everything with -dac (-dap) - # for some reason. - if ( !-s $output_file && -s $ifname && $delete_backup == 1 ) { - Warn( -"output file '$output_file' missing or zero length; original '$ifname' not deleted\n" - ); + # destination stream must be an object with print method + else { + foreach my $line (@lines) { + $destination_stream->print($line); } - else { - unlink($ifname) - or Die( -"unable to remove previous '$ifname' for -b option; check permissions: $!\n" - ); + my $ref_destination_stream = ref($destination_stream); + if ( $ref_destination_stream->can('close') ) { + $destination_stream->close(); } } + } + else { - $logger_object->finish( $infile_syntax_ok, $formatter ) - if $logger_object; - } # end of main loop to process all files + # Empty destination buffer not going to a string ... could + # happen for example if user deleted all pod or comments + } + return; +} ## end sub copy_buffer_to_destination + +} ## end of closure for sub perltidy + +sub line_diff { + + # Given two strings, return + # $diff_marker = a string with carat (^) symbols indicating differences + # $pos1 = character position of first difference; pos1=-1 if no difference + + # Form exclusive or of the strings, which has null characters where strings + # have same common characters so non-null characters indicate character + # differences. + my ( $s1, $s2 ) = @_; + my $diff_marker = EMPTY_STRING; + my $pos = -1; + my $pos1 = $pos; + if ( defined($s1) && defined($s2) ) { + my $count = 0; + my $mask = $s1 ^ $s2; + + while ( $mask =~ /[^\0]/g ) { + $count++; + my $pos_last = $pos; + $pos = $LAST_MATCH_START[0]; + if ( $count == 1 ) { $pos1 = $pos; } + $diff_marker .= SPACE x ( $pos - $pos_last - 1 ) . '^'; + + # we could continue to mark all differences, but there is no point + last; + } + } + return wantarray ? ( $diff_marker, $pos1 ) : $diff_marker; +} ## end sub line_diff + +sub compare_string_buffers { + + # Compare input and output string buffers and return a brief text + # description of the first difference. + my ( $bufi, $bufo, $is_encoded_data ) = @_; + + my $leni = length($bufi); + my $leno = defined($bufo) ? length($bufo) : 0; + my $msg = + "Input file length is $leni chars\nOutput file length is $leno chars\n"; + return $msg unless $leni && $leno; + + my ( $fhi, $fnamei ) = streamhandle( \$bufi, 'r', $is_encoded_data ); + my ( $fho, $fnameo ) = streamhandle( \$bufo, 'r', $is_encoded_data ); + return $msg unless ( $fho && $fhi ); # for safety, shouldn't happen + my ( $linei, $lineo ); + my ( $counti, $counto ) = ( 0, 0 ); + my ( $last_nonblank_line, $last_nonblank_count ) = ( EMPTY_STRING, 0 ); + my $truncate = sub { + my ( $str, $lenmax ) = @_; + if ( length($str) > $lenmax ) { + $str = substr( $str, 0, $lenmax ) . "..."; + } + return $str; + }; + while (1) { + if ($linei) { + $last_nonblank_line = $linei; + $last_nonblank_count = $counti; + } + $linei = $fhi->getline(); + $lineo = $fho->getline(); - NORMAL_EXIT: - return 0; + # compare chomp'ed lines + if ( defined($linei) ) { $counti++; chomp $linei } + if ( defined($lineo) ) { $counto++; chomp $lineo } - ERROR_EXIT: - return 1; -} # end of main program perltidy + # see if one or both ended before a difference + last unless ( defined($linei) && defined($lineo) ); -sub get_stream_as_named_file { + next if ( $linei eq $lineo ); - # Return the name of a file containing a stream of data, creating - # a temporary file if necessary. - # Given: - # $stream - the name of a file or stream - # Returns: - # $fname = name of file if possible, or undef - # $if_tmpfile = true if temp file, undef if not temp file - # - # This routine is needed for passing actual files to Perl for - # a syntax check. - my ($stream) = @_; - my $is_tmpfile; - my $fname; - if ($stream) { - if ( ref($stream) ) { - my ( $fh_stream, $fh_name ) = - Perl::Tidy::streamhandle( $stream, 'r' ); - if ($fh_stream) { - my ( $fout, $tmpnam ) = File::Temp::tempfile(); - if ($fout) { - $fname = $tmpnam; - $is_tmpfile = 1; - binmode $fout; - while ( my $line = $fh_stream->getline() ) { - $fout->print($line); - } - $fout->close(); - } - $fh_stream->close(); + # lines differ ... + my ( $line_diff, $pos1 ) = line_diff( $linei, $lineo ); + my $reason = "Files first differ at character $pos1 of line $counti"; + + my ( $leading_ws_i, $leading_ws_o ) = ( EMPTY_STRING, EMPTY_STRING ); + if ( $linei =~ /^(\s+)/ ) { $leading_ws_i = $1; } + if ( $lineo =~ /^(\s+)/ ) { $leading_ws_o = $1; } + if ( $leading_ws_i ne $leading_ws_o ) { + $reason .= "; leading whitespace differs"; + if ( $leading_ws_i =~ /\t/ ) { + $reason .= "; input has tab char"; + } + } + else { + my ( $trailing_ws_i, $trailing_ws_o ) = + ( EMPTY_STRING, EMPTY_STRING ); + if ( $linei =~ /(\s+)$/ ) { $trailing_ws_i = $1; } + if ( $lineo =~ /(\s+)$/ ) { $trailing_ws_o = $1; } + if ( $trailing_ws_i ne $trailing_ws_o ) { + $reason .= "; trailing whitespace differs"; } } - elsif ( $stream ne '-' && -f $stream ) { - $fname = $stream; + $msg .= $reason . "\n"; + + # limit string display length + if ( $pos1 > 60 ) { + my $drop = $pos1 - 40; + $linei = "..." . substr( $linei, $drop ); + $lineo = "..." . substr( $lineo, $drop ); + $line_diff = SPACE x 3 . substr( $line_diff, $drop ); } + $linei = $truncate->( $linei, 72 ); + $lineo = $truncate->( $lineo, 72 ); + $last_nonblank_line = $truncate->( $last_nonblank_line, 72 ); + + if ($last_nonblank_line) { + my $countm = $counti - 1; + $msg .= <$counto:$lineo +$line_diff +EOM + return $msg; + } ## end while + + # no line differences found, but one file may have fewer lines + if ( $counti > $counto ) { + $msg .= <write_logfile_entry( -"perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n" - ); + # Note: the punctuation variable '$]' is not in older versions of + # English.pm so leave it as is to avoid failing installation tests. + my $msg = +"perltidy version $VERSION log file on a $OSNAME system, OLD_PERL_VERSION=$]\n"; if ($Windows_type) { - $logger_object->write_logfile_entry("Windows type is $Windows_type\n"); + $msg .= "Windows type is $Windows_type\n"; } - my $options_string = join( ' ', @{$rraw_options} ); + my $options_string = join( SPACE, @{$rraw_options} ); if ($config_file) { - $logger_object->write_logfile_entry( - "Found Configuration File >>> $config_file \n"); + $msg .= "Found Configuration File >>> $config_file \n"; } - $logger_object->write_logfile_entry( - "Configuration and command line parameters for this run:\n"); - $logger_object->write_logfile_entry("$options_string\n"); + $msg .= "Configuration and command line parameters for this run:\n"; + $msg .= "$options_string\n"; if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) { $rOpts->{'logfile'} = 1; # force logfile to be saved - $logger_object->write_logfile_entry( - "Final parameter set for this run\n"); - $logger_object->write_logfile_entry( - "------------------------------------\n"); + $msg .= "Final parameter set for this run\n"; + $msg .= "------------------------------------\n"; - $logger_object->write_logfile_entry($readable_options); + $msg .= $readable_options; - $logger_object->write_logfile_entry( - "------------------------------------\n"); + $msg .= "------------------------------------\n"; } - $logger_object->write_logfile_entry( - "To find error messages search for 'WARNING' with your editor\n"); + $msg .= "To find error messages search for 'WARNING' with your editor\n"; + return $msg; +} ## end sub make_logfile_header + +sub write_logfile_header { + my ( + $rOpts, $logger_object, $config_file, + $rraw_options, $Windows_type, $readable_options + ) = @_; + + my $msg = make_logfile_header( $rOpts, $config_file, + $rraw_options, $Windows_type, $readable_options ); + + $logger_object->write_logfile_entry($msg); return; -} +} ## end sub write_logfile_header sub generate_options { @@ -1565,7 +2980,6 @@ sub generate_options { # which is mainly for debugging # scl --> short-concatenation-item-length # helps break at '.' # recombine # for debugging line breaks - # valign # for debugging vertical alignment # I --> DIAGNOSTICS # for debugging [**DEACTIVATED**] ###################################################################### @@ -1579,9 +2993,9 @@ sub generate_options { # i.e., -foo and -nofoo are allowed # a double dash signals the end of the options list # - #--------------------------------------------------------------- + #----------------------------------------------- # Define the option string passed to GetOptions. - #--------------------------------------------------------------- + #----------------------------------------------- my @option_string = (); my %expansion = (); @@ -1621,7 +3035,6 @@ sub generate_options { no-profile npro recombine! - valign! notidy ); @@ -1660,6 +3073,7 @@ sub generate_options { $expansion{$nshort_name} = [$nolong_name]; } } + return; }; # Install long option names which have a simple abbreviation. @@ -1671,6 +3085,8 @@ sub generate_options { ########################### $add_option->( 'backup-and-modify-in-place', 'b', '!' ); $add_option->( 'backup-file-extension', 'bext', '=s' ); + $add_option->( 'backup-method', 'bm', '=s' ); + $add_option->( 'character-encoding', 'enc', '=s' ); $add_option->( 'force-read-binary', 'f', '!' ); $add_option->( 'format', 'fmt', '=s' ); $add_option->( 'iterations', 'it', '=i' ); @@ -1683,8 +3099,9 @@ sub generate_options { $add_option->( 'quiet', 'q', '!' ); $add_option->( 'standard-error-output', 'se', '!' ); $add_option->( 'standard-output', 'st', '!' ); + $add_option->( 'use-unicode-gcstring', 'gcs', '!' ); $add_option->( 'warning-output', 'w', '!' ); - $add_option->( 'character-encoding', 'enc', '=s' ); + $add_option->( 'add-terminal-newline', 'atnl', '!' ); # options which are both toggle switches and values moved here # to hide from tidyview (which does not show category 0 flags): @@ -1707,33 +3124,52 @@ sub generate_options { $add_option->( 'tabs', 't', '!' ); $add_option->( 'default-tabsize', 'dt', '=i' ); $add_option->( 'extended-syntax', 'xs', '!' ); + $add_option->( 'assert-tidy', 'ast', '!' ); + $add_option->( 'assert-untidy', 'asu', '!' ); + $add_option->( 'encode-output-strings', 'eos', '!' ); + $add_option->( 'sub-alias-list', 'sal', '=s' ); + $add_option->( 'grep-alias-list', 'gal', '=s' ); + $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' ); ######################################## $category = 2; # Code indentation control ######################################## - $add_option->( 'continuation-indentation', 'ci', '=i' ); - $add_option->( 'line-up-parentheses', 'lp', '!' ); - $add_option->( 'outdent-keyword-list', 'okwl', '=s' ); - $add_option->( 'outdent-keywords', 'okw', '!' ); - $add_option->( 'outdent-labels', 'ola', '!' ); - $add_option->( 'outdent-long-quotes', 'olq', '!' ); - $add_option->( 'indent-closing-brace', 'icb', '!' ); - $add_option->( 'closing-token-indentation', 'cti', '=i' ); - $add_option->( 'closing-paren-indentation', 'cpi', '=i' ); - $add_option->( 'closing-brace-indentation', 'cbi', '=i' ); - $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' ); - $add_option->( 'brace-left-and-indent', 'bli', '!' ); - $add_option->( 'brace-left-and-indent-list', 'blil', '=s' ); + $add_option->( 'continuation-indentation', 'ci', '=i' ); + $add_option->( 'extended-continuation-indentation', 'xci', '!' ); + $add_option->( 'line-up-parentheses', 'lp', '!' ); + $add_option->( 'extended-line-up-parentheses', 'xlp', '!' ); + $add_option->( 'line-up-parentheses-exclusion-list', 'lpxl', '=s' ); + $add_option->( 'line-up-parentheses-inclusion-list', 'lpil', '=s' ); + $add_option->( 'outdent-keyword-list', 'okwl', '=s' ); + $add_option->( 'outdent-keywords', 'okw', '!' ); + $add_option->( 'outdent-labels', 'ola', '!' ); + $add_option->( 'outdent-long-quotes', 'olq', '!' ); + $add_option->( 'indent-closing-brace', 'icb', '!' ); + $add_option->( 'closing-token-indentation', 'cti', '=i' ); + $add_option->( 'closing-paren-indentation', 'cpi', '=i' ); + $add_option->( 'closing-brace-indentation', 'cbi', '=i' ); + $add_option->( 'closing-square-bracket-indentation', 'csbi', '=i' ); + $add_option->( 'brace-left-and-indent', 'bli', '!' ); + $add_option->( 'brace-left-and-indent-list', 'blil', '=s' ); + $add_option->( 'brace-left-and-indent-exclusion-list', 'blixl', '=s' ); ######################################## $category = 3; # Whitespace control ######################################## + $add_option->( 'add-trailing-commas', 'atc', '!' ); $add_option->( 'add-semicolons', 'asc', '!' ); $add_option->( 'add-whitespace', 'aws', '!' ); $add_option->( 'block-brace-tightness', 'bbt', '=i' ); $add_option->( 'brace-tightness', 'bt', '=i' ); $add_option->( 'delete-old-whitespace', 'dws', '!' ); + $add_option->( 'delete-repeated-commas', 'drc', '!' ); + $add_option->( 'delete-trailing-commas', 'dtc', '!' ); + $add_option->( 'delete-weld-interfering-commas', 'dwic', '!' ); $add_option->( 'delete-semicolons', 'dsm', '!' ); + $add_option->( 'function-paren-vertical-alignment', 'fpva', '!' ); + $add_option->( 'keyword-paren-inner-tightness', 'kpit', '=i' ); + $add_option->( 'keyword-paren-inner-tightness-list', 'kpitl', '=s' ); + $add_option->( 'logical-padding', 'lop', '!' ); $add_option->( 'nospace-after-keyword', 'nsak', '=s' ); $add_option->( 'nowant-left-space', 'nwls', '=s' ); $add_option->( 'nowant-right-space', 'nwrs', '=s' ); @@ -1751,6 +3187,13 @@ sub generate_options { $add_option->( 'trim-pod', 'trp', '!' ); $add_option->( 'want-left-space', 'wls', '=s' ); $add_option->( 'want-right-space', 'wrs', '=s' ); + $add_option->( 'want-trailing-commas', 'wtc', '=s' ); + $add_option->( 'space-prototype-paren', 'spp', '=i' ); + $add_option->( 'valign-code', 'vc', '!' ); + $add_option->( 'valign-block-comments', 'vbc', '!' ); + $add_option->( 'valign-side-comments', 'vsc', '!' ); + $add_option->( 'valign-exclusion-list', 'vxl', '=s' ); + $add_option->( 'valign-inclusion-list', 'vil', '=s' ); ######################################## $category = 4; # Comment controls @@ -1763,6 +3206,9 @@ sub generate_options { $add_option->( 'closing-side-comment-warnings', 'cscw', '!' ); $add_option->( 'closing-side-comments', 'csc', '!' ); $add_option->( 'closing-side-comments-balanced', 'cscb', '!' ); + $add_option->( 'code-skipping', 'cs', '!' ); + $add_option->( 'code-skipping-begin', 'csb', '=s' ); + $add_option->( 'code-skipping-end', 'cse', '=s' ); $add_option->( 'format-skipping', 'fs', '!' ); $add_option->( 'format-skipping-begin', 'fsb', '=s' ); $add_option->( 'format-skipping-end', 'fse', '=s' ); @@ -1771,6 +3217,8 @@ sub generate_options { $add_option->( 'indent-spaced-block-comments', 'isbc', '!' ); $add_option->( 'fixed-position-side-comment', 'fpsc', '=i' ); $add_option->( 'minimum-space-to-comment', 'msc', '=i' ); + $add_option->( 'non-indenting-braces', 'nib', '!' ); + $add_option->( 'non-indenting-brace-prefix', 'nibp', '=s' ); $add_option->( 'outdent-long-comments', 'olc', '!' ); $add_option->( 'outdent-static-block-comments', 'osbc', '!' ); $add_option->( 'static-block-comment-prefix', 'sbcp', '=s' ); @@ -1802,12 +3250,13 @@ sub generate_options { $add_option->( 'paren-vertical-tightness', 'pvt', '=i' ); $add_option->( 'paren-vertical-tightness-closing', 'pvtc', '=i' ); $add_option->( 'weld-nested-containers', 'wn', '!' ); + $add_option->( 'weld-nested-exclusion-list', 'wnxl', '=s' ); + $add_option->( 'weld-fat-comma', 'wfc', '!' ); $add_option->( 'space-backslash-quote', 'sbq', '=i' ); $add_option->( 'stack-closing-block-brace', 'scbb', '!' ); $add_option->( 'stack-closing-hash-brace', 'schb', '!' ); $add_option->( 'stack-closing-paren', 'scp', '!' ); $add_option->( 'stack-closing-square-bracket', 'scsb', '!' ); - $add_option->( 'stack-opening-block-brace', 'sobb', '!' ); $add_option->( 'stack-opening-hash-brace', 'sohb', '!' ); $add_option->( 'stack-opening-paren', 'sop', '!' ); $add_option->( 'stack-opening-square-bracket', 'sosb', '!' ); @@ -1819,6 +3268,22 @@ sub generate_options { $add_option->( 'break-before-all-operators', 'bbao', '!' ); $add_option->( 'keep-interior-semicolons', 'kis', '!' ); $add_option->( 'one-line-block-semicolons', 'olbs', '=i' ); + $add_option->( 'one-line-block-nesting', 'olbn', '=i' ); + $add_option->( 'break-before-hash-brace', 'bbhb', '=i' ); + $add_option->( 'break-before-hash-brace-and-indent', 'bbhbi', '=i' ); + $add_option->( 'break-before-square-bracket', 'bbsb', '=i' ); + $add_option->( 'break-before-square-bracket-and-indent', 'bbsbi', '=i' ); + $add_option->( 'break-before-paren', 'bbp', '=i' ); + $add_option->( 'break-before-paren-and-indent', 'bbpi', '=i' ); + $add_option->( 'brace-left-list', 'bll', '=s' ); + $add_option->( 'brace-left-exclusion-list', 'blxl', '=s' ); + $add_option->( 'break-after-labels', 'bal', '=i' ); + + # This was an experiment mentioned in git #78, originally named -bopl. I + # expanded it to also open logical blocks, based on git discussion #100, + # and renamed it -bocp. It works, but will remain commented out due to + # apparent lack of interest. + # $add_option->( 'break-open-compact-parens', 'bocp', '=s' ); ######################################## $category = 6; # Controlling list formatting @@ -1833,8 +3298,11 @@ sub generate_options { $add_option->( 'break-at-old-keyword-breakpoints', 'bok', '!' ); $add_option->( 'break-at-old-logical-breakpoints', 'bol', '!' ); $add_option->( 'break-at-old-method-breakpoints', 'bom', '!' ); + $add_option->( 'break-at-old-semicolon-breakpoints', 'bos', '!' ); $add_option->( 'break-at-old-ternary-breakpoints', 'bot', '!' ); $add_option->( 'break-at-old-attribute-breakpoints', 'boa', '!' ); + $add_option->( 'keep-old-breakpoints-before', 'kbb', '=s' ); + $add_option->( 'keep-old-breakpoints-after', 'kba', '=s' ); $add_option->( 'ignore-old-breakpoints', 'iob', '!' ); ######################################## @@ -1879,25 +3347,28 @@ sub generate_options { ######################################## $category = 13; # Debugging ######################################## -## $add_option->( 'DIAGNOSTICS', 'I', '!' ); - $add_option->( 'DEBUG', 'D', '!' ); - $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' ); - $add_option->( 'dump-defaults', 'ddf', '!' ); - $add_option->( 'dump-long-names', 'dln', '!' ); - $add_option->( 'dump-options', 'dop', '!' ); - $add_option->( 'dump-profile', 'dpro', '!' ); - $add_option->( 'dump-short-names', 'dsn', '!' ); - $add_option->( 'dump-token-types', 'dtt', '!' ); - $add_option->( 'dump-want-left-space', 'dwls', '!' ); - $add_option->( 'dump-want-right-space', 'dwrs', '!' ); - $add_option->( 'fuzzy-line-length', 'fll', '!' ); - $add_option->( 'help', 'h', '' ); - $add_option->( 'short-concatenation-item-length', 'scl', '=i' ); - $add_option->( 'show-options', 'opt', '!' ); - $add_option->( 'timestamp', 'ts', '!' ); - $add_option->( 'version', 'v', '' ); - $add_option->( 'memoize', 'mem', '!' ); - $add_option->( 'file-size-order', 'fso', '!' ); + $add_option->( 'DIAGNOSTICS', 'I', '!' ) if (DEVEL_MODE); + $add_option->( 'DEBUG', 'D', '!' ); + $add_option->( 'dump-cuddled-block-list', 'dcbl', '!' ); + $add_option->( 'dump-defaults', 'ddf', '!' ); + $add_option->( 'dump-long-names', 'dln', '!' ); + $add_option->( 'dump-options', 'dop', '!' ); + $add_option->( 'dump-profile', 'dpro', '!' ); + $add_option->( 'dump-short-names', 'dsn', '!' ); + $add_option->( 'dump-token-types', 'dtt', '!' ); + $add_option->( 'dump-want-left-space', 'dwls', '!' ); + $add_option->( 'dump-want-right-space', 'dwrs', '!' ); + $add_option->( 'fuzzy-line-length', 'fll', '!' ); + $add_option->( 'help', 'h', EMPTY_STRING ); + $add_option->( 'short-concatenation-item-length', 'scl', '=i' ); + $add_option->( 'show-options', 'opt', '!' ); + $add_option->( 'timestamp', 'ts', '!' ); + $add_option->( 'version', 'v', EMPTY_STRING ); + $add_option->( 'memoize', 'mem', '!' ); + $add_option->( 'file-size-order', 'fso', '!' ); + $add_option->( 'maximum-file-size-mb', 'maxfs', '=i' ); + $add_option->( 'maximum-level-errors', 'maxle', '=i' ); + $add_option->( 'maximum-unexpected-errors', 'maxue', '=i' ); #--------------------------------------------------------------------- @@ -1923,9 +3394,9 @@ sub generate_options { } } - #--------------------------------------------------------------- + #--------------------------------------- # Assign valid ranges to certain options - #--------------------------------------------------------------- + #--------------------------------------- # In the future, these may be used to make preliminary checks # hash keys are long names # If key or value is undefined: @@ -1938,16 +3409,14 @@ sub generate_options { # if max is undefined, there is no upper limit # Parameters not listed here have defaults %option_range = ( - 'format' => [ 'tidy', 'html', 'user' ], - 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], - 'character-encoding' => [ 'none', 'utf8' ], - - 'space-backslash-quote' => [ 0, 2 ], - - 'block-brace-tightness' => [ 0, 2 ], - 'brace-tightness' => [ 0, 2 ], - 'paren-tightness' => [ 0, 2 ], - 'square-bracket-tightness' => [ 0, 2 ], + 'format' => [ 'tidy', 'html', 'user' ], + 'output-line-ending' => [ 'dos', 'win', 'mac', 'unix' ], + 'space-backslash-quote' => [ 0, 2 ], + 'block-brace-tightness' => [ 0, 2 ], + 'keyword-paren-inner-tightness' => [ 0, 2 ], + 'brace-tightness' => [ 0, 2 ], + 'paren-tightness' => [ 0, 2 ], + 'square-bracket-tightness' => [ 0, 2 ], 'block-brace-vertical-tightness' => [ 0, 2 ], 'brace-vertical-tightness' => [ 0, 2 ], @@ -1969,18 +3438,22 @@ sub generate_options { 'keyword-group-blanks-before' => [ 0, 2 ], 'keyword-group-blanks-after' => [ 0, 2 ], + + 'space-prototype-paren' => [ 0, 2 ], + 'break-after-labels' => [ 0, 2 ], ); # Note: we could actually allow negative ci if someone really wants it: # $option_range{'continuation-indentation'} = [ undef, undef ]; - #--------------------------------------------------------------- - # Assign default values to the above options here, except + #------------------------------------------------------------------ + # DEFAULTS: Assign default values to the above options here, except # for 'outfile' and 'help'. # These settings should approximate the perlstyle(1) suggestions. - #--------------------------------------------------------------- + #------------------------------------------------------------------ my @defaults = qw( add-newlines + add-terminal-newline add-semicolons add-whitespace blanks-before-blocks @@ -2000,12 +3473,20 @@ sub generate_options { brace-tightness=1 brace-vertical-tightness-closing=0 brace-vertical-tightness=0 + break-after-labels=0 break-at-old-logical-breakpoints break-at-old-ternary-breakpoints break-at-old-attribute-breakpoints break-at-old-keyword-breakpoints + break-before-hash-brace=0 + break-before-hash-brace-and-indent=0 + break-before-square-bracket=0 + break-before-square-bracket-and-indent=0 + break-before-paren=0 + break-before-paren-and-indent=0 comma-arrow-breakpoints=5 nocheck-syntax + character-encoding=guess closing-side-comment-interval=6 closing-side-comment-maximum-text=20 closing-side-comment-else-flag=0 @@ -2014,22 +3495,30 @@ sub generate_options { closing-brace-indentation=0 closing-square-bracket-indentation=0 continuation-indentation=2 + noextended-continuation-indentation cuddled-break-option=1 delete-old-newlines delete-semicolons extended-syntax + encode-output-strings + function-paren-vertical-alignment fuzzy-line-length hanging-side-comments indent-block-comments indent-columns=4 iterations=1 keep-old-blank-lines=1 + keyword-paren-inner-tightness=1 + logical-padding long-block-line-count=8 look-for-autoloader look-for-selfloader maximum-consecutive-blank-lines=1 maximum-fields-per-table=0 maximum-line-length=80 + maximum-file-size-mb=10 + maximum-level-errors=1 + maximum-unexpected-errors=0 memoize minimum-space-to-comment=4 nobrace-left-and-indent @@ -2037,13 +3526,14 @@ sub generate_options { nodelete-old-whitespace nohtml nologfile + non-indenting-braces noquiet noshow-options nostatic-side-comments notabs nowarning-output - character-encoding=none one-line-block-semicolons=1 + one-line-block-nesting=0 outdent-labels outdent-long-quotes outdent-long-comments @@ -2053,10 +3543,14 @@ sub generate_options { pass-version-line noweld-nested-containers recombine - valign + nouse-unicode-gcstring + valign-code + valign-block-comments + valign-side-comments short-concatenation-item-length=8 space-for-semicolon space-backslash-quote=1 + space-prototype-paren=1 square-bracket-tightness=1 square-bracket-vertical-tightness-closing=0 square-bracket-vertical-tightness=0 @@ -2064,7 +3558,9 @@ sub generate_options { timestamp trim-qw format=tidy + backup-method=copy backup-file-extension=bak + code-skipping format-skipping default-tabsize=8 @@ -2075,16 +3571,16 @@ sub generate_options { push @defaults, "perl-syntax-check-flags=-c -T"; - #--------------------------------------------------------------- + #----------------------------------------------------------------------- # Define abbreviations which will be expanded into the above primitives. # These may be defined recursively. - #--------------------------------------------------------------- + #----------------------------------------------------------------------- %expansion = ( %expansion, - 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)], - 'fnl' => [qw(freeze-newlines)], - 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)], - 'fws' => [qw(freeze-whitespace)], + 'freeze-newlines' => [qw(noadd-newlines nodelete-old-newlines)], + 'fnl' => [qw(freeze-newlines)], + 'freeze-whitespace' => [qw(noadd-whitespace nodelete-old-whitespace)], + 'fws' => [qw(freeze-whitespace)], 'freeze-blank-lines' => [qw(maximum-consecutive-blank-lines=0 keep-old-blank-lines=2)], 'fbl' => [qw(freeze-blank-lines)], @@ -2092,16 +3588,17 @@ sub generate_options { 'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)], 'nooutdent-long-lines' => [qw(nooutdent-long-quotes nooutdent-long-comments)], - 'noll' => [qw(nooutdent-long-lines)], - 'io' => [qw(indent-only)], + 'oll' => [qw(outdent-long-lines)], + 'noll' => [qw(nooutdent-long-lines)], + 'io' => [qw(indent-only)], 'delete-all-comments' => [qw(delete-block-comments delete-side-comments delete-pod)], 'nodelete-all-comments' => [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)], - 'dac' => [qw(delete-all-comments)], - 'ndac' => [qw(nodelete-all-comments)], - 'gnu' => [qw(gnu-style)], - 'pbp' => [qw(perl-best-practices)], + 'dac' => [qw(delete-all-comments)], + 'ndac' => [qw(nodelete-all-comments)], + 'gnu' => [qw(gnu-style)], + 'pbp' => [qw(perl-best-practices)], 'tee-all-comments' => [qw(tee-block-comments tee-side-comments tee-pod)], 'notee-all-comments' => @@ -2112,12 +3609,15 @@ sub generate_options { 'nhtml' => [qw(format=tidy)], 'tidy' => [qw(format=tidy)], + 'brace-left' => [qw(opening-brace-on-new-line)], + # -cb is now a synonym for -ce 'cb' => [qw(cuddled-else)], 'cuddled-blocks' => [qw(cuddled-else)], - 'utf8' => [qw(character-encoding=utf8)], - 'UTF8' => [qw(character-encoding=utf8)], + 'utf8' => [qw(character-encoding=utf8)], + 'UTF8' => [qw(character-encoding=utf8)], + 'guess' => [qw(character-encoding=guess)], 'swallow-optional-blank-lines' => [qw(kbl=0)], 'noswallow-optional-blank-lines' => [qw(kbl=1)], @@ -2180,7 +3680,7 @@ sub generate_options { 'nostack-opening-tokens' => [qw(nsop nsohb nsosb)], 'sct' => [qw(scp schb scsb)], - 'stack-closing-tokens' => => [qw(scp schb scsb)], + 'stack-closing-tokens' => [qw(scp schb scsb)], 'nsct' => [qw(nscp nschb nscsb)], 'nostack-closing-tokens' => [qw(nscp nschb nscsb)], @@ -2206,6 +3706,14 @@ sub generate_options { 'conv' => [qw(it=4)], 'nconv' => [qw(it=1)], + 'valign' => [qw(vc vsc vbc)], + 'novalign' => [qw(nvc nvsc nvbc)], + + # NOTE: This is a possible future shortcut. But it will remain + # deactivated until the -lpxl flag is no longer experimental. + # 'line-up-function-parentheses' => [ qw(lp), q#lpxl=[ { F(2# ], + # 'lfp' => [qw(line-up-function-parentheses)], + # 'mangle' originally deleted pod and comments, but to keep it # reversible, it no longer does. But if you really want to # delete them, just use: @@ -2217,7 +3725,6 @@ sub generate_options { 'mangle' => [ qw( - check-syntax keep-old-blank-lines=0 delete-old-newlines delete-old-whitespace @@ -2232,7 +3739,7 @@ sub generate_options { blank-lines-before-subs=0 blank-lines-before-packages=0 notabs - ) + ) ], # 'extrude' originally deleted pod and comments, but to keep it @@ -2243,10 +3750,6 @@ sub generate_options { # An interesting use for 'extrude' is to do this: # perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new # which will break up all one-line blocks. - # - # Removed 'check-syntax' option, which is unsafe because it may execute - # code in BEGIN blocks. Example 'Moose/debugger-duck_type.t'. - 'extrude' => [ qw( ci=0 @@ -2264,7 +3767,7 @@ sub generate_options { nofuzzy-line-length notabs norecombine - ) + ) ], # this style tries to follow the GNU Coding Standards (which do @@ -2273,7 +3776,7 @@ sub generate_options { 'gnu-style' => [ qw( lp bl noll pt=2 bt=2 sbt=2 cpi=1 csbi=1 cbi=1 - ) + ) ], # Style suggested in Damian Conway's Perl Best Practices @@ -2294,7 +3797,7 @@ q(wbb=% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= \%option_category, \%option_range ); -} # end of generate_options +} ## end sub generate_options # Memoize process_command_line. Given same @ARGV passed in, return same # values and same @ARGV back. @@ -2329,7 +3832,7 @@ sub process_command_line { else { return _process_command_line(@q); } -} +} ## end sub process_command_line # (note the underscore here) sub _process_command_line { @@ -2346,9 +3849,11 @@ sub _process_command_line { # breaking old versions of Perl without these routines. # Previous configuration is reset at the exit of this routine. my $glc; - eval { $glc = Getopt::Long::Configure() }; - unless ($@) { - eval { Getopt::Long::ConfigDefaults() }; + if ( eval { $glc = Getopt::Long::Configure(); 1 } ) { + my $ok = eval { Getopt::Long::ConfigDefaults(); 1 }; + if ( !$ok && DEVEL_MODE ) { + Fault("Failed call to Getopt::Long::ConfigDefaults: $EVAL_ERROR\n"); + } } else { $glc = undef } @@ -2357,9 +3862,9 @@ sub _process_command_line { $roption_category, $roption_range ) = generate_options(); - #--------------------------------------------------------------- + #-------------------------------------------------------------- # set the defaults by passing the above list through GetOptions - #--------------------------------------------------------------- + #-------------------------------------------------------------- my %Opts = (); { local @ARGV = (); @@ -2377,15 +3882,15 @@ sub _process_command_line { my $word; my @raw_options = (); - my $config_file = ""; + my $config_file = EMPTY_STRING; my $saw_ignore_profile = 0; my $saw_dump_profile = 0; - #--------------------------------------------------------------- + #-------------------------------------------------------------- # Take a first look at the command-line parameters. Do as many # immediate dumps as possible, which can avoid confusion if the # perltidyrc file has an error. - #--------------------------------------------------------------- + #-------------------------------------------------------------- foreach my $i (@ARGV) { $i =~ s/^--/-/; @@ -2420,8 +3925,8 @@ sub _process_command_line { } } unless ( -e $config_file ) { - Warn("cannot find file given with -pro=$config_file: $!\n"); - $config_file = ""; + Warn("cannot find file given with -pro=$config_file: $ERRNO\n"); + $config_file = EMPTY_STRING; } } elsif ( $i =~ /^-(pro|profile)=?$/ ) { @@ -2458,9 +3963,9 @@ sub _process_command_line { Exit(1); } - #--------------------------------------------------------------- + #---------------------------------------- # read any .perltidyrc configuration file - #--------------------------------------------------------------- + #---------------------------------------- unless ($saw_ignore_profile) { # resolve possible conflict between $perltidyrc_stream passed @@ -2482,7 +3987,7 @@ EOM # look for a config file if we don't have one yet my $rconfig_file_chatter; - ${$rconfig_file_chatter} = ""; + ${$rconfig_file_chatter} = EMPTY_STRING; $config_file = find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter, $rpending_complaint ) @@ -2578,9 +4083,9 @@ EOM } } - #--------------------------------------------------------------- + #---------------------------------------- # now process the command line parameters - #--------------------------------------------------------------- + #---------------------------------------- expand_command_abbreviations( $rexpansion, \@raw_options, $config_file ); local $SIG{'__WARN__'} = sub { Warn( $_[0] ) }; @@ -2589,19 +4094,93 @@ EOM } # reset Getopt::Long configuration back to its previous value - eval { Getopt::Long::Configure($glc) } if defined $glc; + if ( defined($glc) ) { + my $ok = eval { Getopt::Long::Configure($glc); 1 }; + if ( !$ok && DEVEL_MODE ) { + Fault("Could not reset Getopt::Long configuration: $EVAL_ERROR\n"); + } + } return ( \%Opts, $config_file, \@raw_options, $roption_string, $rexpansion, $roption_category, $roption_range ); -} # end of _process_command_line +} ## end sub _process_command_line + +sub make_grep_alias_string { + my ($rOpts) = @_; + + # Defaults: list operators in List::Util + # Possible future additions: pairfirst pairgrep pairmap + my $default_string = join SPACE, qw( + all + any + first + none + notall + reduce + reductions + ); + + # make a hash of any excluded words + my %is_excluded_word; + my $exclude_string = $rOpts->{'grep-alias-exclusion-list'}; + if ($exclude_string) { + $exclude_string =~ s/,/ /g; # allow commas + $exclude_string =~ s/^\s+//; + $exclude_string =~ s/\s+$//; + my @q = split /\s+/, $exclude_string; + @is_excluded_word{@q} = (1) x scalar(@q); + } + + # The special option -gaxl='*' removes all defaults + if ( $is_excluded_word{'*'} ) { $default_string = EMPTY_STRING } + + # combine the defaults and any input list + my $input_string = $rOpts->{'grep-alias-list'}; + if ($input_string) { $input_string .= SPACE . $default_string } + else { $input_string = $default_string } + + # Now make the final list of unique grep alias words + $input_string =~ s/,/ /g; # allow commas + $input_string =~ s/^\s+//; + $input_string =~ s/\s+$//; + my @word_list = split /\s+/, $input_string; + my @filtered_word_list; + my %seen; + + foreach my $word (@word_list) { + if ($word) { + if ( $word !~ /^\w[\w\d]*$/ ) { + Warn( + "unexpected word in --grep-alias-list: '$word' - ignoring\n" + ); + } + if ( !$seen{$word} && !$is_excluded_word{$word} ) { + $seen{$word}++; + push @filtered_word_list, $word; + } + } + } + my $joined_words = join SPACE, @filtered_word_list; + $rOpts->{'grep-alias-list'} = $joined_words; + return; +} ## end sub make_grep_alias_string sub check_options { my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_; - #--------------------------------------------------------------- + #------------------------------------------------------------ # check and handle any interactions among the basic options.. - #--------------------------------------------------------------- + #------------------------------------------------------------ + + # Since perltidy only encodes in utf8, problems can occur if we let it + # decode anything else. See discussions for issue git #83. + my $encoding = $rOpts->{'character-encoding'}; + if ( $encoding !~ /^\s*(guess|none|utf8|utf-8)\s*$/i ) { + Die(<{'closing-paren-indentation'} = $cti; } - # In quiet mode, there is no log file and hence no way to report - # results of syntax check, so don't do it. - if ( $rOpts->{'quiet'} ) { - $rOpts->{'check-syntax'} = 0; - } - - # can't check syntax if no output - if ( $rOpts->{'format'} ne 'tidy' ) { - $rOpts->{'check-syntax'} = 0; - } - - # Never let Windows 9x/Me systems run syntax check -- this will prevent a - # wide variety of nasty problems on these systems, because they cannot - # reliably run backticks. Don't even think about changing this! - if ( $rOpts->{'check-syntax'} - && $is_Windows - && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) ) - { - $rOpts->{'check-syntax'} = 0; - } - - ########################################################################### - # Added Dec 2017: Deactivating check-syntax for all systems for safety - # because unexpected results can occur when code in BEGIN blocks is - # executed. This flag was included to help check for perltidy mistakes, - # and may still be useful for debugging. To activate for testing comment - # out the next three lines. Also fix sub 'do_check_syntax' in this file. - ########################################################################### - else { - $rOpts->{'check-syntax'} = 0; - } - - # It's really a bad idea to check syntax as root unless you wrote - # the script yourself. FIXME: not sure if this works with VMS - unless ($is_Windows) { - - if ( $< == 0 && $rOpts->{'check-syntax'} ) { - $rOpts->{'check-syntax'} = 0; - ${$rpending_complaint} .= -"Syntax check deactivated for safety; you shouldn't run this as root\n"; - } - } - - # check iteration count and quietly fix if necessary: - # - iterations option only applies to code beautification mode - # - the convergence check should stop most runs on iteration 2, and - # virtually all on iteration 3. But we'll allow up to 6. - if ( $rOpts->{'format'} ne 'tidy' ) { - $rOpts->{'iterations'} = 1; - } - elsif ( defined( $rOpts->{'iterations'} ) ) { - if ( $rOpts->{'iterations'} <= 0 ) { $rOpts->{'iterations'} = 1 } - elsif ( $rOpts->{'iterations'} > 6 ) { $rOpts->{'iterations'} = 6 } - } - else { - $rOpts->{'iterations'} = 1; - } + # Syntax checking is no longer supported due to concerns about executing + # code in BEGIN blocks. The flag is still accepted for backwards + # compatibility but is ignored if set. + $rOpts->{'check-syntax'} = 0; my $check_blank_count = sub { my ( $key, $abbrev ) = @_; @@ -2700,6 +4226,7 @@ sub check_options { $rOpts->{$key} = 100; } } + return; }; # check for reasonable number of blank lines and fix to avoid problems @@ -2729,19 +4256,23 @@ sub check_options { $rOpts->{'indent-block-comments'} = 1; } - # -bli flag implies -bl - if ( $rOpts->{'brace-left-and-indent'} ) { - $rOpts->{'opening-brace-on-new-line'} = 1; - } + # -bar cannot be used with -bl or -bli; arbitrarily keep -bar + if ( $rOpts->{'opening-brace-always-on-right'} ) { - if ( $rOpts->{'opening-brace-always-on-right'} - && $rOpts->{'opening-brace-on-new-line'} ) - { - Warn(<{'opening-brace-on-new-line'} ) { + Warn(<{'opening-brace-on-new-line'} = 0; + $rOpts->{'opening-brace-on-new-line'} = 0; + } + if ( $rOpts->{'brace-left-and-indent'} ) { + Warn(<{'brace-left-and-indent'} = 0; + } } # it simplifies things if -bl is 0 rather than undefined @@ -2749,12 +4280,6 @@ EOM $rOpts->{'opening-brace-on-new-line'} = 0; } - # -sbl defaults to -bl if not defined - if ( !defined( $rOpts->{'opening-sub-brace-on-new-line'} ) ) { - $rOpts->{'opening-sub-brace-on-new-line'} = - $rOpts->{'opening-brace-on-new-line'}; - } - if ( $rOpts->{'entab-leading-whitespace'} ) { if ( $rOpts->{'entab-leading-whitespace'} < 0 ) { Warn("-et=n must use a positive integer; ignoring -et\n"); @@ -2762,7 +4287,14 @@ EOM } # entab leading whitespace has priority over the older 'tabs' option - if ( $rOpts->{'tabs'} ) { $rOpts->{'tabs'} = 0; } + if ( $rOpts->{'tabs'} ) { + + # The following warning could be added but would annoy a lot of + # users who have a perltidyrc with both -t and -et=n. So instead + # there is a note in the manual that -et overrides -t. + ##Warn("-tabs and -et=n conflict; ignoring -tabs\n"); + $rOpts->{'tabs'} = 0; + } } # set a default tabsize to be used in guessing the starting indentation @@ -2782,6 +4314,55 @@ EOM $rOpts->{'default-tabsize'} = 8; } + # Check and clean up any sub-alias-list + if ( $rOpts->{'sub-alias-list'} ) { + my $sub_alias_string = $rOpts->{'sub-alias-list'}; + $sub_alias_string =~ s/,/ /g; # allow commas + $sub_alias_string =~ s/^\s+//; + $sub_alias_string =~ s/\s+$//; + my @sub_alias_list = split /\s+/, $sub_alias_string; + my @filtered_word_list = ('sub'); + my %seen; + + # include 'sub' for later convenience + $seen{sub}++; + foreach my $word (@sub_alias_list) { + if ($word) { + if ( $word !~ /^\w[\w\d]*$/ ) { + Warn("unexpected sub alias '$word' - ignoring\n"); + } + if ( !$seen{$word} ) { + $seen{$word}++; + push @filtered_word_list, $word; + } + } + } + $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list; + } + + make_grep_alias_string($rOpts); + + # Turn on fuzzy-line-length unless this is an extrude run, as determined + # by the -i and -ci settings. Otherwise blinkers can form (case b935) + if ( !$rOpts->{'fuzzy-line-length'} ) { + if ( $rOpts->{'maximum-line-length'} != 1 + || $rOpts->{'continuation-indentation'} != 0 ) + { + $rOpts->{'fuzzy-line-length'} = 1; + } + } + + # The freeze-whitespace option is currently a derived option which has its + # own key + $rOpts->{'freeze-whitespace'} = !$rOpts->{'add-whitespace'} + && !$rOpts->{'delete-old-whitespace'}; + + # Turn off certain options if whitespace is frozen + # Note: vertical alignment will be automatically shut off + if ( $rOpts->{'freeze-whitespace'} ) { + $rOpts->{'logical-padding'} = 0; + } + # Define $tabsize, the number of spaces per tab for use in # guessing the indentation of source lines with leading tabs. # Assume same as for this run if tabs are used , otherwise assume @@ -2792,7 +4373,7 @@ EOM : $rOpts->{'tabs'} ? $rOpts->{'indent-columns'} : $rOpts->{'default-tabsize'}; return $tabsize; -} +} ## end sub check_options sub find_file_upwards { my ( $search_dir, $search_file ) = @_; @@ -2816,7 +4397,7 @@ sub find_file_upwards { # This return is for Perl-Critic. # We shouldn't get out of the while loop without a return return; -} +} ## end sub find_file_upwards sub expand_command_abbreviations { @@ -2828,7 +4409,6 @@ sub expand_command_abbreviations { # 10 should be plenty, but it may be increased to allow deeply # nested expansions. my $max_passes = 10; - my @new_argv = (); # keep looping until all expansions have been converted into actual # dash parameters.. @@ -2857,7 +4437,7 @@ sub expand_command_abbreviations { # to allow abbreviations with arguments such as '-vt=1' if ( $rexpansion->{ $abr . $flags } ) { $abr = $abr . $flags; - $flags = ""; + $flags = EMPTY_STRING; } # if we see this dash item in the expansion hash.. @@ -2882,15 +4462,15 @@ sub expand_command_abbreviations { else { push( @new_argv, $word ); } - } # end of this pass + } ## end of this pass # update parameter list @ARGV to the new one @ARGV = @new_argv; - last unless ( $abbrev_count > 0 ); + last if ( !$abbrev_count ); # make sure we are not in an infinite loop if ( $pass_count == $max_passes ) { - local $" = ')('; + local $LIST_SEPARATOR = ')('; Warn(<{$abbrev} }; print STDOUT "$abbrev --> @list\n"; } return; -} +} ## end sub dump_short_names sub check_vms_filename { @@ -2968,13 +4548,13 @@ sub check_vms_filename { \.-?\d*$ # match . version number /$1/x; - # normalise filename, if there are no unescaped dots then append one + # normalize filename, if there are no unescaped dots then append one $base .= '.' unless $base =~ /(?:^|[^^])\./; # if we don't already have an extension then we just append the extension - my $separator = ( $base =~ /\.$/ ) ? "" : "_"; + my $separator = ( $base =~ /\.$/ ) ? EMPTY_STRING : "_"; return ( $path . $base, $separator ); -} +} ## end sub check_vms_filename sub Win_OS_Type { @@ -2988,8 +4568,8 @@ sub Win_OS_Type { # We need to know this to decide where to look for config files my $rpending_complaint = shift; - my $os = ""; - return $os unless $^O =~ /win32|dos/i; # is it a MS box? + my $os = EMPTY_STRING; + return $os unless $OSNAME =~ /win32|dos/i; # is it a MS box? # Systems built from Perl source may not have Win32.pm # But probably have Win32::GetOSVersion() anyway so the @@ -2998,7 +4578,13 @@ sub Win_OS_Type { # Use the standard API call to determine the version my ( $undef, $major, $minor, $build, $id ); - eval { ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion() }; + my $ok = eval { + ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion(); + 1; + }; + if ( !$ok && DEVEL_MODE ) { + Fault("Could not cal Win32::GetOSVersion(): $EVAL_ERROR\n"); + } # # NAME ID MAJOR MINOR @@ -3013,20 +4599,20 @@ sub Win_OS_Type { 1 => { 0 => "95", 10 => "98", - 90 => "Me" + 90 => "Me", }, 2 => { - 0 => "2000", # or NT 4, see below + 0 => "2000", # or NT 4, see below 1 => "XP/.Net", 2 => "Win2003", - 51 => "NT3.51" + 51 => "NT3.51", } }->{$id}->{$minor}; # If $os is undefined, the above code is out of date. Suggested updates # are welcome. unless ( defined $os ) { - $os = ""; + $os = EMPTY_STRING; # Deactivated this message 20180322 because it was needlessly # causing some test scripts to fail. Need help from someone @@ -3040,14 +4626,14 @@ EOS # Unfortunately the logic used for the various versions isn't so clever.. # so we have to handle an outside case. return ( $os eq "2000" && $major != 5 ) ? "NT4" : $os; -} +} ## end sub Win_OS_Type sub is_unix { return - ( $^O !~ /win32|dos/i ) - && ( $^O ne 'VMS' ) - && ( $^O ne 'OS2' ) - && ( $^O ne 'MacOS' ); + ( $OSNAME !~ /win32|dos/i ) + && ( $OSNAME ne 'VMS' ) + && ( $OSNAME ne 'OS2' ) + && ( $OSNAME ne 'MacOS' ); } sub look_for_Windows { @@ -3055,25 +4641,26 @@ sub look_for_Windows { # determine Windows sub-type and location of # system-wide configuration files my $rpending_complaint = shift; - my $is_Windows = ( $^O =~ /win32|dos/i ); + my $is_Windows = ( $OSNAME =~ /win32|dos/i ); my $Windows_type; $Windows_type = Win_OS_Type($rpending_complaint) if $is_Windows; return ( $is_Windows, $Windows_type ); -} +} ## end sub look_for_Windows sub find_config_file { # look for a .perltidyrc configuration file # For Windows also look for a file named perltidy.ini my ( $is_Windows, $Windows_type, $rconfig_file_chatter, - $rpending_complaint ) = @_; + $rpending_complaint ) + = @_; ${$rconfig_file_chatter} .= "# Config file search...system reported as:"; if ($is_Windows) { ${$rconfig_file_chatter} .= "Windows $Windows_type\n"; } else { - ${$rconfig_file_chatter} .= " $^O\n"; + ${$rconfig_file_chatter} .= " $OSNAME\n"; } # sub to check file existence and record all tests @@ -3123,7 +4710,7 @@ sub find_config_file { # Check the NT/2k/XP locations, first a local machine def, then a # network def - push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i; + push @envs, qw(USERPROFILE HOMESHARE) if $OSNAME =~ /win32/i; # Now go through the environment ... foreach my $var (@envs) { @@ -3185,11 +4772,11 @@ sub find_config_file { } # Place to add customization code for other systems - elsif ( $^O eq 'OS2' ) { + elsif ( $OSNAME eq 'OS2' ) { } - elsif ( $^O eq 'MacOS' ) { + elsif ( $OSNAME eq 'MacOS' ) { } - elsif ( $^O eq 'VMS' ) { + elsif ( $OSNAME eq 'VMS' ) { } # Assume some kind of Unix @@ -3204,7 +4791,7 @@ sub find_config_file { # Couldn't find a config file return; -} +} ## end sub find_config_file sub Win_Config_Locs { @@ -3213,17 +4800,13 @@ sub Win_Config_Locs { # Directory, and All Users Directory. All Users will be empty on a # 9x/Me box. Contributed by: Yves Orton. - # Original coding: - # my $rpending_complaint = shift; - # my $os = (@_) ? shift : Win_OS_Type(); - my ( $rpending_complaint, $os ) = @_; if ( !$os ) { $os = Win_OS_Type(); } return unless $os; - my $system = ""; - my $allusers = ""; + my $system = EMPTY_STRING; + my $allusers = EMPTY_STRING; if ( $os =~ /9[58]|Me/ ) { $system = "C:/Windows"; @@ -3244,21 +4827,24 @@ sub Win_Config_Locs { return; } return wantarray ? ( $os, $system, $allusers ) : $os; -} +} ## end sub Win_Config_Locs sub dump_config_file { my ( $fh, $config_file, $rconfig_file_chatter ) = @_; - print STDOUT "$$rconfig_file_chatter"; + print STDOUT "${$rconfig_file_chatter}"; if ($fh) { print STDOUT "# Dump of file: '$config_file'\n"; while ( my $line = $fh->getline() ) { print STDOUT $line } - eval { $fh->close() }; + my $ok = eval { $fh->close(); 1 }; + if ( !$ok && DEVEL_MODE ) { + Fault("Could not close file handle(): $EVAL_ERROR\n"); + } } else { print STDOUT "# ...no config file found\n"; } return; -} +} ## end sub dump_config_file sub read_config_file { @@ -3266,7 +4852,7 @@ sub read_config_file { my @config_list = (); # file is bad if non-empty $death_message is returned - my $death_message = ""; + my $death_message = EMPTY_STRING; my $name = undef; my $line_no; @@ -3297,15 +4883,15 @@ sub read_config_file { $opening_brace_line = $line_no unless ( $body && $body =~ s/\}$// ); # handle a new alias definition - if ( ${$rexpansion}{$name} ) { - local $" = ')('; - my @names = sort keys %$rexpansion; + if ( $rexpansion->{$name} ) { + local $LIST_SEPARATOR = ')('; + my @names = sort keys %{$rexpansion}; $death_message = "Here is a list of all installed aliases\n(@names)\n" - . "Attempting to redefine alias ($name) in config file $config_file line $.\n"; + . "Attempting to redefine alias ($name) in config file $config_file line $INPUT_LINE_NUMBER\n"; last; } - ${$rexpansion}{$name} = []; + $rexpansion->{$name} = []; } # leading opening braces not allowed @@ -3346,7 +4932,7 @@ EOM # remove leading dashes if this is an alias foreach ( @{$rbody_parts} ) { s/^\-+//; } - push @{ ${$rexpansion}{$name} }, @{$rbody_parts}; + push @{ $rexpansion->{$name} }, @{$rbody_parts}; } else { push( @config_list, @{$rbody_parts} ); @@ -3358,19 +4944,22 @@ EOM $death_message = "Didn't see a '}' to match the '{' at line $opening_brace_line in config file '$config_file'\n"; } - eval { $fh->close() }; + my $ok = eval { $fh->close(); 1 }; + if ( !$ok && DEVEL_MODE ) { + Fault("Could not close file handle(): $EVAL_ERROR\n"); + } return ( \@config_list, $death_message ); -} +} ## end sub read_config_file sub strip_comment { # Strip any comment from a command line my ( $instr, $config_file, $line_no ) = @_; - my $msg = ""; + my $msg = EMPTY_STRING; # check for full-line comment if ( $instr =~ /^\s*#/ ) { - return ( "", $msg ); + return ( EMPTY_STRING, $msg ); } # nothing to do if no comments @@ -3391,14 +4980,14 @@ sub strip_comment { } # handle comments and quotes - my $outstr = ""; - my $quote_char = ""; + my $outstr = EMPTY_STRING; + my $quote_char = EMPTY_STRING; while (1) { # looking for ending quote character if ($quote_char) { if ( $instr =~ /\G($quote_char)/gc ) { - $quote_char = ""; + $quote_char = EMPTY_STRING; $outstr .= $1; } elsif ( $instr =~ /\G(.)/gc ) { @@ -3438,7 +5027,7 @@ EOM } } return ( $outstr, $msg ); -} +} ## end sub strip_comment sub parse_args { @@ -3452,15 +5041,20 @@ sub parse_args { my ($body) = @_; my @body_parts = (); - my $quote_char = ""; - my $part = ""; - my $msg = ""; + my $quote_char = EMPTY_STRING; + my $part = EMPTY_STRING; + my $msg = EMPTY_STRING; + + # Check for external call with undefined $body - added to fix + # github issue Perl-Tidy-Sweetened issue #23 + if ( !defined($body) ) { $body = EMPTY_STRING } + while (1) { # looking for ending quote character if ($quote_char) { if ( $body =~ /\G($quote_char)/gc ) { - $quote_char = ""; + $quote_char = EMPTY_STRING; } elsif ( $body =~ /\G(.)/gc ) { $part .= $1; @@ -3484,7 +5078,7 @@ EOM } elsif ( $body =~ /\G(\s+)/gc ) { if ( length($part) ) { push @body_parts, $part; } - $part = ""; + $part = EMPTY_STRING; } elsif ( $body =~ /\G(.)/gc ) { $part .= $1; @@ -3496,14 +5090,14 @@ EOM } } return ( \@body_parts, $msg ); -} +} ## end sub parse_args sub dump_long_names { my @names = @_; print STDOUT < does not take an argument # =s takes a mandatory string @@ -3514,12 +5108,12 @@ sub dump_long_names { # i.e., -foo and -nofoo are allowed # a double dash signals the end of the options list # -#--------------------------------------------------------------- +#-------------------------------------------------- EOM foreach my $name ( sort @names ) { print STDOUT "$name\n" } return; -} +} ## end sub dump_long_names sub dump_defaults { my @defaults = @_; @@ -3539,7 +5133,7 @@ sub readable_options { $readable_options .= "# See utility 'perltidyrc_dump.pl' for nicer formatting.\n"; foreach my $opt ( @{$roption_string} ) { - my $flag = ""; + my $flag = EMPTY_STRING; if ( $opt =~ /(.*)(!|=.*)$/ ) { $opt = $1; $flag = $2; @@ -3552,7 +5146,7 @@ sub readable_options { my $flag = $rGetopt_flags->{$key}; my $value = $rOpts->{$key}; my $prefix = '--'; - my $suffix = ""; + my $suffix = EMPTY_STRING; if ($flag) { if ( $flag =~ /^=/ ) { if ( $value !~ /^\d+$/ ) { $value = '"' . $value . '"' } @@ -3571,13 +5165,13 @@ sub readable_options { $readable_options .= $prefix . $key . $suffix . "\n"; } return $readable_options; -} +} ## end sub readable_options sub show_version { print STDOUT <<"EOM"; This is perltidy, v$VERSION -Copyright 2000-2019, Steve Hancock +Copyright 2000-2022, Steve Hancock Perltidy is free software and may be copied under the terms of the GNU General Public License, which is included in the distribution files. @@ -3586,7 +5180,7 @@ Complete documentation for perltidy can be found using 'man perltidy' or on the internet at http://perltidy.sourceforge.net. EOM return; -} +} ## end sub show_version sub usage { @@ -3612,7 +5206,6 @@ I/O control -bext=s change default backup extension from 'bak' to s -q deactivate error messages (for running under editor) -w include non-critical warning messages in the .ERR error output - -syn run perl -c to check syntax (default under unix systems) -log save .LOG file, which has useful diagnostics -f force perltidy to read a binary file -g like -log but writes more detailed .LOG file, for debugging scripts @@ -3625,7 +5218,7 @@ I/O control Basic Options: -i=n use n columns per indentation level (default n=4) - -t tabs: use one tab character per indentation level, not recommeded + -t tabs: use one tab character per indentation level, not recommended -nt no tabs: use n spaces per indentation level (default) -et=n entab leading whitespace n spaces per tab; not recommended -io "indent only": just do indentation, no other formatting. @@ -3690,6 +5283,8 @@ Line Break Control -wba=s want break after tokens in string; i.e. wba=': .' -wbb=s want break before tokens in string -wn weld nested: combines opening and closing tokens when both are adjacent + -wnxl=s weld nested exclusion list: provides some control over the types of + containers which can be welded Following Old Breakpoints -kis keep interior semicolons. Allows multiple statements per line. @@ -3786,164 +5381,6 @@ or go to the perltidy home page at http://perltidy.sourceforge.net EOF return; -} - -sub process_this_file { - - my ( $tokenizer, $formatter ) = @_; - - while ( my $line = $tokenizer->get_line() ) { - $formatter->write_line($line); - } - my $severe_error = $tokenizer->report_tokenization_errors(); - eval { $formatter->finish_formatting($severe_error) }; - - return; -} - -sub check_syntax { - - # Use 'perl -c' to make sure that we did not create bad syntax - # This is a very good independent check for programming errors - # - # Given names of the input and output files, ($istream, $ostream), - # we do the following: - # - check syntax of the input file - # - if bad, all done (could be an incomplete code snippet) - # - if infile syntax ok, then check syntax of the output file; - # - if outfile syntax bad, issue warning; this implies a code bug! - # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good - - my ( $istream, $ostream, $logger_object, $rOpts ) = @_; - my $infile_syntax_ok = 0; - my $line_of_dashes = '-' x 42 . "\n"; - - my $flags = $rOpts->{'perl-syntax-check-flags'}; - - # be sure we invoke perl with -c - # note: perl will accept repeated flags like '-c -c'. It is safest - # to append another -c than try to find an interior bundled c, as - # in -Tc, because such a 'c' might be in a quoted string, for example. - if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" } - - # be sure we invoke perl with -x if requested - # same comments about repeated parameters applies - if ( $rOpts->{'look-for-hash-bang'} ) { - if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" } - } - - # this shouldn't happen unless a temporary file couldn't be made - if ( $istream eq '-' ) { - $logger_object->write_logfile_entry( - "Cannot run perl -c on STDIN and STDOUT\n"); - return $infile_syntax_ok; - } - - $logger_object->write_logfile_entry( - "checking input file syntax with perl $flags\n"); - - # Not all operating systems/shells support redirection of the standard - # error output. - my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1'; - - my ( $istream_filename, $perl_output ) = - do_syntax_check( $istream, $flags, $error_redirection ); - $logger_object->write_logfile_entry( - "Input stream passed to Perl as file $istream_filename\n"); - $logger_object->write_logfile_entry($line_of_dashes); - $logger_object->write_logfile_entry("$perl_output\n"); - - if ( $perl_output =~ /syntax\s*OK/ ) { - $infile_syntax_ok = 1; - $logger_object->write_logfile_entry($line_of_dashes); - $logger_object->write_logfile_entry( - "checking output file syntax with perl $flags ...\n"); - my ( $ostream_filename, $perl_output ) = - do_syntax_check( $ostream, $flags, $error_redirection ); - $logger_object->write_logfile_entry( - "Output stream passed to Perl as file $ostream_filename\n"); - $logger_object->write_logfile_entry($line_of_dashes); - $logger_object->write_logfile_entry("$perl_output\n"); - - unless ( $perl_output =~ /syntax\s*OK/ ) { - $logger_object->write_logfile_entry($line_of_dashes); - $logger_object->warning( -"The output file has a syntax error when tested with perl $flags $ostream !\n" - ); - $logger_object->warning( - "This implies an error in perltidy; the file $ostream is bad\n" - ); - $logger_object->report_definite_bug(); - - # the perl version number will be helpful for diagnosing the problem - $logger_object->write_logfile_entry( $^V . "\n" ); - } - } - else { - - # Only warn of perl -c syntax errors. Other messages, - # such as missing modules, are too common. They can be - # seen by running with perltidy -w - $logger_object->complain("A syntax check using perl $flags\n"); - $logger_object->complain( - "for the output in file $istream_filename gives:\n"); - $logger_object->complain($line_of_dashes); - $logger_object->complain("$perl_output\n"); - $logger_object->complain($line_of_dashes); - $infile_syntax_ok = -1; - $logger_object->write_logfile_entry($line_of_dashes); - $logger_object->write_logfile_entry( -"The output file will not be checked because of input file problems\n" - ); - } - return $infile_syntax_ok; -} - -sub do_syntax_check { - - # This should not be called; the syntax check is deactivated - Die("Unexpected call for syntax check-shouldn't happen\n"); - return; -} - -=pod -sub do_syntax_check { - my ( $stream, $flags, $error_redirection ) = @_; - - ############################################################ - # This code is not reachable because syntax check is deactivated, - # but it is retained for reference. - ############################################################ - - # We need a named input file for executing perl - my ( $stream_filename, $is_tmpfile ) = get_stream_as_named_file($stream); - - # TODO: Need to add name of file to log somewhere - # otherwise Perl output is hard to read - if ( !$stream_filename ) { return $stream_filename, "" } - - # We have to quote the filename in case it has unusual characters - # or spaces. Example: this filename #CM11.pm# gives trouble. - my $quoted_stream_filename = '"' . $stream_filename . '"'; - - # Under VMS something like -T will become -t (and an error) so we - # will put quotes around the flags. Double quotes seem to work on - # Unix/Windows/VMS, but this may not work on all systems. (Single - # quotes do not work under Windows). It could become necessary to - # put double quotes around each flag, such as: -"c" -"T" - # We may eventually need some system-dependent coding here. - $flags = '"' . $flags . '"'; - - # now wish for luck... - my $msg = qx/perl $flags $quoted_stream_filename $error_redirection/; - - if ($is_tmpfile) { - unlink $stream_filename - or Perl::Tidy::Die("couldn't unlink stream $stream_filename: $!\n"); - } - return $stream_filename, $msg; -} -=cut +} ## end sub usage 1; -