From bbc1525a0beda68645d1860763eee64591187c85 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Fri, 17 Jun 2022 17:59:34 -0700 Subject: [PATCH] simplify structure --- lib/Perl/Tidy.pm | 2279 ++++++++++++++++++++++++++-------------------- 1 file changed, 1299 insertions(+), 980 deletions(-) diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index 211b8ad7..3f27bc68 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -104,14 +104,14 @@ 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 development. 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 = '20220613'; } @@ -317,8 +317,7 @@ sub find_input_line_ending { my $missing_file_spec; BEGIN { - eval { require File::Spec }; - $missing_file_spec = $EVAL_ERROR; + $missing_file_spec = !eval { require File::Spec; 1 }; } sub catfile { @@ -386,10 +385,12 @@ sub find_input_line_ending { # 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. @@ -420,6 +421,53 @@ sub is_char_mode { 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++, + _tabsize_ => $i++, + _teefile_stream_ => $i++, + _user_formatter_ => $i++, + }; +} + sub perltidy { my %input_hash = @_; @@ -446,7 +494,7 @@ sub perltidy { ); # Status information which can be returned for diagnostic purposes. - # This is intended for testing and subject to change. + # NOTE: This is intended only for testing and subject to change. # List of "key => value" hash entries: @@ -486,7 +534,7 @@ sub perltidy { # blinking => true if stopped on blinking states # ( i.e., unstable formatting, should not happen ) - my $rstatus = { + $rstatus = { file_count => 0, opt_format => EMPTY_STRING, @@ -575,6 +623,9 @@ EOM $fh_stderr = *STDERR; } + my $self = []; + bless $self, __PACKAGE__; + sub Exit { my $flag = shift; if ($flag) { goto ERROR_EXIT } @@ -589,25 +640,6 @@ EOM croak "unexpected return to Die"; } - 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; - }; - # extract various dump parameters my $dump_options_type = $input_hash{'dump_options_type'}; my $dump_options = $get_hash_ref->('dump_options'); @@ -679,8 +711,11 @@ EOM } } + # These string refs will hold any warnings and error messages to be written + # to the logfile object when it eventually gets created. my $rpending_complaint; ${$rpending_complaint} = EMPTY_STRING; + my $rpending_logfile_message; ${$rpending_logfile_message} = EMPTY_STRING; @@ -698,10 +733,11 @@ EOM $dot = '.'; $dot_pattern = '\.'; # must escape for use in regex } + $self->[_file_extension_separator_] = $dot; - #--------------------------------------------------------------- + #------------------------- # get command line options - #--------------------------------------------------------------- + #------------------------- my ( $rOpts, $config_file, $rraw_options, $roption_string, $rexpansion, $roption_category, $roption_range ) = process_command_line( @@ -709,12 +745,14 @@ EOM $rpending_complaint, $dump_options_type, ); + $self->[_rOpts_] = $rOpts; + my $saw_pbp = grep { $_ eq '-pbp' || $_ eq '-perl-best-practices' } @{$rraw_options}; - #--------------------------------------------------------------- + #------------------------------------ # Handle requests to dump information - #--------------------------------------------------------------- + #------------------------------------ # return or exit immediately after all dumps my $quit_now = 0; @@ -770,9 +808,9 @@ EOM Exit(0); } - #--------------------------------------------------------------- + #---------------------------------------- # check parameters and their interactions - #--------------------------------------------------------------- + #---------------------------------------- my $tabsize = check_options( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ); @@ -800,61 +838,13 @@ EOM 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 $output_extension = + $self->make_file_extension( $rOpts->{'output-file-extension'}, + $default_file_extension{ $rOpts->{'format'} } ); - my $html_toc_extension = - make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot ); - - my $html_src_extension = - make_extension( $rOpts->{'html-src-extension'}, 'src', $dot ); - - # 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 ); # Turn off assert-tidy and assert-untidy unless we are tidying files if ( $rOpts->{'format'} ne 'tidy' ) { @@ -920,17 +910,13 @@ EOM # 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 - my $loaded_unicode_gcstring; if ( !$rOpts->{'use-unicode-gcstring'} ) { $loaded_unicode_gcstring = 0; } - #--------------------------------------------------------------- - # Ready to go... + #------------------------------------------------ # main loop to process all files in argument list - #--------------------------------------------------------------- - my $formatter = undef; - my $tokenizer = undef; + #------------------------------------------------ # Remove duplicate filenames. Otherwise, for example if the user entered # perltidy -b myfile.pl myfile.pl @@ -951,13 +937,14 @@ EOM my $number_of_files = @ARGV; while ( my $input_file = shift @ARGV ) { + my $fileroot; my @input_file_stat; my $display_name; - #--------------------------------------------------------------- + #-------------------------- # prepare this input stream - #--------------------------------------------------------------- + #-------------------------- if ($source_stream) { $fileroot = "perltidy"; $display_name = ""; @@ -1050,6 +1037,7 @@ EOM if ( $OSNAME eq 'VMS' ) { ( $fileroot, $dot ) = check_vms_filename($fileroot); + $self->[_file_extension_separator_] = $dot; } # add option to change path here @@ -1088,216 +1076,30 @@ EOM next; } - # the 'source_object' supplies a method to read the input file - my $source_object = Perl::Tidy::LineSource->new( - input_file => $input_file, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - ); - next unless ($source_object); - - my $max_iterations = $rOpts->{'iterations'}; - my $do_convergence_test = $max_iterations > 1; - my $convergence_log_message; - my %saw_md5; - my $digest_input = 0; - - my $buf = EMPTY_STRING; - while ( my $line = $source_object->get_line() ) { - $buf .= $line; - } - - my $remove_terminal_newline = - !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/; - - # Decode the input stream if necessary or requested - 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); }; - if ($EVAL_ERROR) { - - $encoding_log_message .= <get_decoded_string_buffer( $input_file, $display_name, + $rpending_logfile_message ); - $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; + # Skip this file on any error + next if ( !defined($buf) ); - # Define the function to determine the display width of character - # strings - my $length_function = sub { return length( $_[0] ) }; - if ($is_encoded_data) { - - # Delete any Byte Order Mark (BOM), which can cause trouble - $buf =~ s/^\x{FEFF}//; - - # Try to load Unicode::GCString for defining text display width, if - # requested, when the first encoded file is encountered - if ( !defined($loaded_unicode_gcstring) ) { - eval { require Unicode::GCString }; - $loaded_unicode_gcstring = !$EVAL_ERROR; - if ( $EVAL_ERROR && $rOpts->{'use-unicode-gcstring'} ) { - Warn(<new( $_[0] )->columns; - }; - $encoding_log_message .= <{'gcs_used'} = 1; - } - } - - # MD5 sum of input file is evaluated before any prefilter - my $saved_input_buf; - if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) { - $digest_input = $md5_hex->($buf); - $saved_input_buf = $buf; - } - - # 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. - - $buf = $prefilter->($buf) if $prefilter; - - # starting MD5 sum for convergence test is evaluated after any prefilter - if ($do_convergence_test) { - my $digest = $md5_hex->($buf); - $saw_md5{$digest} = 0; - } - - $source_object = Perl::Tidy::LineSource->new( - input_file => \$buf, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - ); - - # register this file name with the Diagnostics package + # 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; @@ -1370,8 +1172,12 @@ EOM } else { if ($in_place_modify) { - $output_file = IO::File->new_tmpfile() - or Die("cannot open temp file for -b option: $ERRNO\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 { @@ -1386,702 +1192,1248 @@ EOM $rstatus->{'iteration_count'} = 0; $rstatus->{'converged'} = 0; - my $fh_tee; - my $tee_file = $fileroot . $dot . "TEE"; - if ($teefile_stream) { $tee_file = $teefile_stream } - if ( $rOpts->{'tee-pod'} - || $rOpts->{'tee-block-comments'} - || $rOpts->{'tee-side-comments'} ) - { - ( $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"); - } + #------------------------------------------ + # 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 => $rOpts, + log_file => $log_file, + warning_file => $warning_file, + fh_stderr => $fh_stderr, + display_name => $display_name, + is_encoded_data => $is_encoded_data, + ); + write_logfile_header( + $rOpts, $logger_object, $config_file, + $rraw_options, $Windows_type, $readable_options, + ); + $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} ); + } + if ( ${$rpending_complaint} ) { + $logger_object->complain( ${$rpending_complaint} ); } 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); - # the 'sink_object' knows how to write the output file - my ( $sink_object, $postfilter_buffer ); - my $use_buffer = - $postfilter - || $remove_terminal_newline - || $rOpts->{'assert-tidy'} - || $rOpts->{'assert-untidy'}; - - # Postpone final output to a destination SCALAR or ARRAY ref to allow - # possible encoding at the end of processing. - my $destination_buffer; - my $use_destination_buffer; - my $encode_destination_buffer; - my $ref_destination_stream = ref($destination_stream); - if ( $ref_destination_stream && !$user_formatter ) { - $use_destination_buffer = 1; - $output_file = \$destination_buffer; - - # 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; + # 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->[_diagnostics_object_] = $diagnostics_object; + $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->[_postfilter_] = $postfilter; + $self->[_prefilter_] = $prefilter; + $self->[_tabsize_] = $tabsize; + $self->[_teefile_stream_] = $teefile_stream; + $self->[_user_formatter_] = $user_formatter; + + #---------------------------------------------------------- + # 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) { + $self->backup_and_modify_in_place( + $input_file, $output_file, + $backup_extension, $delete_backup + ); + $output_file = $input_file; + } + + #--------------------------------------------------------- + # Set output file ownership and permissions if appropriate + #--------------------------------------------------------- + if ( $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 ); + } + + # else use default permissions for html and any other format } + } + + $logger_object->finish() + if $logger_object; + + } ## end of main loop to process all files + + # 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. - # An object with a print method will use file encoding rules - elsif ( $ref_destination_stream->can('print') ) { - $encode_destination_buffer = $is_encoded_data; + # 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 + + # 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. + + NORMAL_EXIT: + my $ret = $Warn_count ? 2 : 0; + return wantarray ? ( $ret, $rstatus ) : $ret; + + ERROR_EXIT: + return wantarray ? ( 1, $rstatus ) : 1; + +} ## end sub perltidy + +sub make_file_extension { + + # Make a file extension, adding any leading '.' if necessary. + # (the '.' may actually be an '_' under VMS). + my ( $self, $extension, $default ) = @_; + + # '$extension' is the first choice (usually a user entry) + # '$default' is a backup extension + + $extension = EMPTY_STRING unless defined($extension); + $extension =~ s/^\s+//; + $extension =~ s/\s+$//; + + # 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+$//; + } + + # 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 + +sub check_in_place_modify { + + my ( $self, $source_stream, $destination_stream ) = @_; + + # get parameters associated with the -b option + my $rOpts = $self->[_rOpts_]; + + # check for -b option; + # silently ignore unless beautify mode + my $in_place_modify = $rOpts->{'backup-and-modify-in-place'} + && $rOpts->{'format'} eq 'tidy'; + + 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' ); + } + + return ( $in_place_modify, $backup_extension, $delete_backup ); +} + +sub backup_and_modify_in_place { + + my ( $self, $input_file, $output_file, $backup_extension, $delete_backup ) + = @_; + + # Handle the -b (--backup-and-modify-in-place) option: + # - First move $input file to $backup_name. + # - Then copy $output_file to $input_file. + # - Then delete the backup if requested + + # NOTES: + # - Die immediately on any error. + # - $output_file is actually an ARRAY ref + # - $input_file permissions will be set by sub set_output_file_permissions + + my $backup_name = $input_file . $backup_extension; + + unless ( -f $input_file ) { + + # 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" + ); + } + if ( -f $backup_name ) { + unlink($backup_name) + or Die( +"unable to remove previous '$backup_name' for -b option; check permissions: $ERRNO\n" + ); + } + + # 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: $ERRNO"); + } + else { + rename( $input_file, $backup_name ) + or Die( +"problem renaming $input_file to $backup_name for -b option: $ERRNO\n" + ); + } + + # Open a file with the original input file name for writing ... + my $is_encoded_data = $self->[_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"); + + #--------------------------------------------------------- + # 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 $output_file && -s $backup_name && $delete_backup == 1 ) { + Warn( +"output file '$output_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_and_modify_in_place + +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" + ); + } + } + } + + # 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); + } + + 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 { - confess <{'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_filter_layer { + + my ( $self, $buf ) = @_; + + # 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 three layers of subroutines: + # *process_filter_layer - do any pre and post processing; *THIS LAYER + # process_iteration_layer - handle any iterations on formatting + # process_single_case - actual solves on 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 + + 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_]; + + # evaluate MD5 sum of input file for assert tests before any prefilter + my $digest_input = 0; + my $saved_input_buf; + if ( $rOpts->{'assert-tidy'} || $rOpts->{'assert-untidy'} ) { + $digest_input = $md5_hex->($buf); + $saved_input_buf = $buf; + } + + my $remove_terminal_newline = + !$rOpts->{'add-terminal-newline'} && substr( $buf, -1, 1 ) !~ /\n/; + + # Create a 'sink_object' which knows how to write the output file + my ( $sink_object, $postfilter_buffer ); + + #----------------------- + # Setup prefilter 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. + my $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 - this will receive the formatted output + # $use_destination_buffer - is $destination_buffer used? + # $encode_destination_buffer - is $destination_buffer to be encoded? + # These are used by sub 'copy_buffer_to_destination', below + + my $destination_buffer; + my $use_destination_buffer; + my $encode_destination_buffer; + + my $ref_destination_stream = ref($destination_stream); + if ( $ref_destination_stream && !$user_formatter ) { + $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; + } + + # 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 <new( - output_file => $use_buffer ? \$postfilter_buffer : $output_file, - line_separator => $line_separator, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - is_encoded_data => $is_encoded_data, - ); + #------------------------------------------- + # 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, + rOpts => $rOpts, + is_encoded_data => $is_encoded_data, + ); - #--------------------------------------------------------------- - # 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 } + #------------------------------------------------------- + # Apply any prefilter. The prefilter is a code reference + # that will be applied to the source before tidying. + #------------------------------------------------------- + $buf = $prefilter->($buf) if $prefilter; - my $logger_object = Perl::Tidy::Logger->new( + #---------------------------------------------------------- + # Format contents of string '$buf', iterating if requested. + # Formatted result will be written to '$sink_object' + #---------------------------------------------------------- + $self->process_iteration_layer( $buf, $sink_object ); + $sink_object->close_output_file() if $sink_object; + + #-------------------------------- + # Do postfilter buffer processing + #-------------------------------- + if ($use_postfilter_buffer) { + + $sink_object = Perl::Tidy::LineSink->new( + output_file => $output_file, + line_separator => $line_separator, rOpts => $rOpts, - log_file => $log_file, - warning_file => $warning_file, - fh_stderr => $fh_stderr, - display_name => $display_name, is_encoded_data => $is_encoded_data, ); - write_logfile_header( - $rOpts, $logger_object, $config_file, - $rraw_options, $Windows_type, $readable_options, + + # 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(); + } + } + 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" + ); + } + } + + my $source_object = Perl::Tidy::LineSource->new( + input_file => \$buf_post, + rOpts => $rOpts, ); - $logger_object->write_logfile_entry($encoding_log_message) - if $encoding_log_message; - if ( ${$rpending_logfile_message} ) { - $logger_object->write_logfile_entry( ${$rpending_logfile_message} ); + # Copy the filtered buffer to the final destination + if ( !$remove_terminal_newline ) { + while ( my $line = $source_object->get_line() ) { + $sink_object->write_line($line); + } } - if ( ${$rpending_complaint} ) { - $logger_object->complain( ${$rpending_complaint} ); + else { + + # 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->write_line($line) if ($line); + $line = $next_line; + } + if ($line) { + $sink_object->set_line_separator(undef); + chomp $line; + $sink_object->write_line($line); + } + } + + $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 ... + if ($is_encoded_data) { + $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 ) = @_; + + # Do all formatting, iterating if requested, on the source string $buf. + # Return the result in the $sink_object. + + # Total formatting is done with three layers of subroutines: + # process_filter_layer - do any pre and post processing + # *process_iteration_layer - do any iterations on formatting; *THIS LAYER + # process_single_case - actual solves on formatting problem + + # Data Flow in this layer: + # $buf -> [ loop over iterations ] -> $sink_object + + 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, + ); + + # 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"); } + } - #--------------------------------------------------------------- - # initialize the debug object, if any - #--------------------------------------------------------------- - my $debugger_object = undef; - if ( $rOpts->{DEBUG} ) { - my $debug_file = $fileroot . $dot . "DEBUG"; - if ($debugfile_stream) { $debug_file = $debugfile_stream } - $debugger_object = - Perl::Tidy::Debugger->new( $debug_file, $is_encoded_data ); - } - - #--------------------------------------------------------------- - # loop over iterations for one source stream - #--------------------------------------------------------------- - - # 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; - my $fh_tee_final = $fh_tee; - my $iteration_of_formatter_convergence; - - 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, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - is_encoded_data => $is_encoded_data, - ); - } - else { - $sink_object = $sink_object_final; - } + my $convergence_log_message; + my $max_iterations = $rOpts->{'iterations'}; - # 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 = undef; - $logger_object = undef; - $fh_tee = undef; - } + # 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 ( !defined($max_iterations) + || $max_iterations <= 0 + || $rOpts->{'format'} ne 'tidy' ) + { + $max_iterations = 1; + } + elsif ( $max_iterations > 6 ) { $max_iterations = 6 } + + # get starting MD5 sum for convergence test + my %saw_md5; + my $do_convergence_test = $max_iterations > 1; + if ($do_convergence_test) { + my $digest = $md5_hex->($buf); + $saw_md5{$digest} = 0; + } - #------------------------------------------------------------ - # create a formatter for this file : html writer or - # pretty printer - #------------------------------------------------------------ + # 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; - # we have to delete any old formatter because, for safety, - # the formatter will check to see that there is only one. - $formatter = undef; + #--------------------- + # Loop over iterations + #--------------------- + foreach my $iter ( 1 .. $max_iterations ) { - if ($user_formatter) { - $formatter = $user_formatter; - } - elsif ( $rOpts->{'format'} eq 'html' ) { - $formatter = Perl::Tidy::HtmlWriter->new( - input_file => $fileroot, - html_file => $output_file, - extension => $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, - diagnostics_object => $diagnostics_object, - 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"); - } + $rstatus->{'iteration_count'} += 1; - unless ($formatter) { - Die("Unable to continue with $rOpts->{'format'} formatting\n"); - } + # 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, + rOpts => $rOpts, + is_encoded_data => $is_encoded_data, + ); + } + else { + $sink_object = $sink_object_final; + } - #--------------------------------------------------------------- - # create the tokenizer for this file - #--------------------------------------------------------------- - $tokenizer = undef; # must destroy old tokenizer - $tokenizer = Perl::Tidy::Tokenizer->new( - source_object => $source_object, + # 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, - 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'}, + 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"); + } - #--------------------------------------------------------------- - # now we can do it - #--------------------------------------------------------------- - process_this_file( $tokenizer, $formatter ); + #----------------------------------- + # 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'}, + ); - #--------------------------------------------------------------- - # close the input source and report errors - #--------------------------------------------------------------- - $source_object->close_input_file(); + #--------------------------------- + # do processing for this iteration + #--------------------------------- + process_single_case( $tokenizer, $formatter ); - # 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; - } + #----------------------------------------- + # 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 ) { + # 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, - rpending_logfile_message => $rpending_logfile_message, - ); + $sink_object->close_output_file(); + $source_object = Perl::Tidy::LineSource->new( + input_file => \$sink_buffer, + rOpts => $rOpts, + ); - # stop iterations if errors or converged - my $stop_now = $tokenizer->report_tokenization_errors(); - $stop_now ||= $tokenizer->get_unexpected_error_count(); - my $stopping_on_error = $stop_now; - 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 { + my $digest = $md5_hex->($sink_buffer); + if ( !defined( $saw_md5{$digest} ) ) { + $saw_md5{$digest} = $iter; + } + else { - # Deja vu, stop iterating - $stop_now = 1; - my $iterm = $iter - 1; - if ( $saw_md5{$digest} != $iterm ) { - - # Blinking (oscillating) between two or more stable - # end states. This is unlikely to occur with normal - # parameters, but it can occur in stress testing - # with extreme parameter values, such as very short - # maximum line lengths. We want to catch and fix - # them when they happen. - $rstatus->{'blinking'} = 1; - $convergence_log_message = <{'blinking'} = 1; + $convergence_log_message = <write_diagnostics( - $convergence_log_message) - if $diagnostics_object; + $stopping_on_error ||= $convergence_log_message; + if (DEVEL_MODE) { + print STDERR $convergence_log_message; + } + $diagnostics_object->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; - $rstatus->{'converged'} = 1; - } + $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 ($stop_now) { - if (DEVEL_MODE) { + if (DEVEL_MODE) { - if ( defined($iteration_of_formatter_convergence) ) { + if ( defined($iteration_of_formatter_convergence) ) { - # 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 ) { + # 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 no conv in $display_name: stopping on it=$iter, but not converged in formatter\n"; +"STRANGE Early conv in $display_name: Stopping on it=$iter, converged in formatter on $iteration_of_formatter_convergence\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); + elsif ( !$stopping_on_error ) { + print STDERR +"STRANGE no conv in $display_name: stopping on it=$iter, but not converged in formatter\n"; } - $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; - $fh_tee = $fh_tee_final; - - $logger_object->write_logfile_entry($convergence_log_message) - if $convergence_log_message; - - #--------------------------------------------------------------- - # Perform any postfilter operation - #--------------------------------------------------------------- - if ($use_buffer) { - $sink_object->close_output_file(); - $sink_object = Perl::Tidy::LineSink->new( - output_file => $output_file, - line_separator => $line_separator, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - is_encoded_data => $is_encoded_data, - ); - - 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(); - ## $Warn_count ||= 1; # logger warning does this now } - } - 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" - ); - ## $Warn_count ||= 1; # logger warning does this now - } - } - - $source_object = Perl::Tidy::LineSource->new( - input_file => \$buf_post, - rOpts => $rOpts, - rpending_logfile_message => $rpending_logfile_message, - ); - # Copy the filtered buffer to the final destination - if ( !$remove_terminal_newline ) { + # 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; } - else { - - # 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->write_line($line) if ($line); - $line = $next_line; - } - if ($line) { - $sink_object->set_line_separator(undef); - chomp $line; - $sink_object->write_line($line); - } - } + } ## end if ( $iter < $max_iterations) + } ## end loop over iterations for one source file - $source_object->close_input_file(); - } - - #------------------------------------------------------------------ - # For string output, store the result to the destination, encoding - # if requested. This is a fix for issue git #83 (tidyall issue) - #------------------------------------------------------------------ - if ($use_destination_buffer) { + $debugger_object->close_debug_file() if $debugger_object; + $fh_tee->close() if $fh_tee; + $logger_object = $logger_object_final; + $logger_object->write_logfile_entry($convergence_log_message) + if $convergence_log_message; - # At this point, all necessary encoding has been done except for - # output to a string or array ref. We use the -eos flag to decide - # if we should encode. - - # -neos, DEFAULT: perltidy does not return encoded string output. - # This is a result of the code evolution but not very convenient for - # most applications. It would be hard to change without breaking - # some programs. + return; +} ## end sub process_iteration_layer - # -eos flag set: If perltidy decodes a string, regardless of - # source, it encodes before returning. - $rstatus->{'output_encoded_as'} = EMPTY_STRING; +sub process_single_case { - if ($encode_destination_buffer) { - my $encoded_buffer; - eval { - $encoded_buffer = - Encode::encode( "UTF-8", $destination_buffer, - Encode::FB_CROAK | Encode::LEAVE_SRC ); - }; - if ($EVAL_ERROR) { + # run the formatter on a single defined case + my ( $tokenizer, $formatter ) = @_; - Warn( -"Error attempting to encode output string ref; encoding not done\n" - ); - } - else { - $destination_buffer = $encoded_buffer; - $rstatus->{'output_encoded_as'} = 'UTF-8'; - } - } + # Total formatting is done with three layers of subroutines: + # 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 - # 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; - } + while ( my $line = $tokenizer->get_line() ) { + $formatter->write_line($line); + } + my $severe_error = $tokenizer->report_tokenization_errors(); - # destination stream must be an object with print method - else { - foreach my $line (@lines) { - $destination_stream->print($line); - } - if ( $ref_destination_stream->can('close') ) { - $destination_stream->close(); - } - } - } - else { + # 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'); - # Empty destination buffer not going to a string ... could - # happen for example if user deleted all pod or comments - } - } - else { + return; +} ## end sub process_single_case - # output went to a file ... - if ($is_encoded_data) { - $rstatus->{'output_encoded_as'} = 'UTF-8'; - } - } +sub copy_buffer_to_destination { - # Save names of the input and output files - my $ifname = $input_file; - my $ofname = $output_file; + my ( $self, $destination_buffer, $destination_stream, + $encode_destination_buffer ) + = @_; - #--------------------------------------------------------------- - # handle the -b option (backup and modify in-place) - #--------------------------------------------------------------- - if ($in_place_modify) { - unless ( -f $input_file ) { + # Copy $destination_buffer to the final $destination_stream, + # encoding if the flag $encode_destination_buffer is true. - # 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: $ERRNO\n" - ); - } + # Data Flow: + # $destination_buffer -> [ encode? ] -> $destination_stream - # 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: $ERRNO"); - } - else { - rename( $input_file, $backup_name ) - or Die( -"problem renaming $input_file to $backup_name for -b option: $ERRNO\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: $ERRNO\n"); + $rstatus->{'output_encoded_as'} = EMPTY_STRING; - 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" - ); + if ($encode_destination_buffer) { + my $encoded_buffer; + if ( + !eval { + $encoded_buffer = + Encode::encode( "UTF-8", $destination_buffer, + Encode::FB_CROAK | Encode::LEAVE_SRC ); + 1; } + ) + { - my $line; - while ( $line = $output_file->getline() ) { - $fout->print($line); - } - $fout->close(); - $output_file = $input_file; - $ofname = $input_file; + Warn( +"Error attempting to encode output string ref; encoding not done\n" + ); } - - #--------------------------------------------------------------- - # clean up and report errors - #--------------------------------------------------------------- - $sink_object->close_output_file() if $sink_object; - $debugger_object->close_debug_file() if $debugger_object; - - # set output file permissions - if ( $output_file && -f $output_file && !-l $output_file ) { - if (@input_file_stat) { - - # 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 { - - # 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" - ); - } - } - } - - # 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); - } - - 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" - ); - } - } - - # else use default permissions for html and any other format - } + else { + $destination_buffer = $encoded_buffer; + $rstatus->{'output_encoded_as'} = 'UTF-8'; } + } - #--------------------------------------------------------------- - # 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->get_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: $ERRNO\n" - ); + my $ref_destination_stream = ref($destination_stream); + if ( $ref_destination_stream->can('close') ) { + $destination_stream->close(); } } + } + else { - $logger_object->finish($formatter) - if $logger_object; - } ## end of main loop to process all files - - # 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. - - # 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 - - # 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. - - NORMAL_EXIT: - my $ret = $Warn_count ? 2 : 0; - return wantarray ? ( $ret, $rstatus ) : $ret; - - ERROR_EXIT: - return wantarray ? ( 1, $rstatus ) : 1; + # 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 sub perltidy } ## end of closure for sub perltidy sub line_diff { @@ -2276,23 +2628,6 @@ sub fileglob_to_re { return "^$x\\z"; # match whole word } -sub make_extension { - - # Make a file extension, including any leading '.' if necessary - # The '.' may actually be an '_' under VMS - my ( $extension, $default, $dot ) = @_; - - # Use the default if none specified - $extension = $default unless ($extension); - - # Only extensions with these leading characters get a '.' - # This rule gives the user some freedom - if ( $extension =~ /^[a-zA-Z0-9]/ ) { - $extension = $dot . $extension; - } - return $extension; -} ## end sub make_extension - sub write_logfile_header { my ( $rOpts, $logger_object, $config_file, @@ -2370,9 +2705,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 = (); @@ -2764,9 +3099,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: @@ -2816,11 +3151,11 @@ sub generate_options { # Note: we could actually allow negative ci if someone really wants it: # $option_range{'continuation-indentation'} = [ undef, undef ]; - #--------------------------------------------------------------- + #------------------------------------------------------------------ # 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 @@ -2940,10 +3275,10 @@ 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)], @@ -3218,9 +3553,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_ERROR) { - 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 } @@ -3229,9 +3566,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 = (); @@ -3253,11 +3590,11 @@ sub _process_command_line { 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/^--/-/; @@ -3330,9 +3667,9 @@ sub _process_command_line { Exit(1); } - #--------------------------------------------------------------- + #---------------------------------------- # read any .perltidyrc configuration file - #--------------------------------------------------------------- + #---------------------------------------- unless ($saw_ignore_profile) { # resolve possible conflict between $perltidyrc_stream passed @@ -3450,9 +3787,9 @@ EOM } } - #--------------------------------------------------------------- + #---------------------------------------- # now process the command line parameters - #--------------------------------------------------------------- + #---------------------------------------- expand_command_abbreviations( $rexpansion, \@raw_options, $config_file ); local $SIG{'__WARN__'} = sub { Warn( $_[0] ) }; @@ -3461,7 +3798,12 @@ 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 ); @@ -3531,9 +3873,9 @@ 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. @@ -3576,21 +3918,6 @@ EOM # compatibility but is ignored if set. $rOpts->{'check-syntax'} = 0; - # 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; - } - my $check_blank_count = sub { my ( $key, $abbrev ) = @_; if ( $rOpts->{$key} ) { @@ -3843,7 +4170,7 @@ sub expand_command_abbreviations { # 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 ) { @@ -3955,7 +4282,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 @@ -4171,10 +4504,6 @@ 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(); } @@ -4210,7 +4539,10 @@ sub dump_config_file { 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"; @@ -4316,7 +4648,10 @@ 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 @@ -4466,7 +4801,7 @@ sub dump_long_names { my @names = @_; print STDOUT < does not take an argument # =s takes a mandatory string @@ -4477,7 +4812,7 @@ 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" } @@ -4752,20 +5087,4 @@ EOF return; } ## end sub usage -sub process_this_file { - - my ( $tokenizer, $formatter ) = @_; - - while ( my $line = $tokenizer->get_line() ) { - $formatter->write_line($line); - } - my $severe_error = $tokenizer->report_tokenization_errors(); - - # 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'); - - return; -} ## end sub process_this_file 1; -- 2.39.5