+ 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 );
+} ## end sub check_in_place_modify
+
+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 );
+
+ # set the modification time of the copy to the original value (rt#145999)
+ my ( $read_time, $write_time ) = @input_file_stat[ 8, 9 ];
+ if ( defined($write_time) ) {
+ utime( $read_time, $write_time, $backup_file )
+ || Warn("error setting times for backup file '$backup_file'\n");
+ }
+
+ # 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(<<EOM);
+Programming error: unable to print to '$input_file' with -b option:
+unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
+EOM
+ }
+
+ $fout->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 );
+
+ # Keep original modification time if no change (rt#145999)
+ if ( !$self->[_input_output_difference_] && defined($write_time) ) {
+ utime( $read_time, $write_time, $input_file )
+ || Warn("error setting times for '$input_file'\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_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(<<EOM);
+inode changed with -bm=copy for file '$input_file': inode_input=$inode_input inode_output=$inode_output
+EOM
+ }
+ }
+
+ return;
+} ## end sub backup_method_copy
+
+sub backup_method_move {
+
+ my ( $self, $input_file, $output_file, $backup_extension, $delete_backup )
+ = @_;
+
+ # Handle the -b (--backup-and-modify-in-place) option with -bm='move':
+ # - 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"
+ );
+ }
+
+ my @input_file_stat = stat($input_file);
+
+ # 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(<<EOM);
+Programming error: unable to print to '$input_file' with -b option:
+unexpected ref type '$ref'; expecting 'ARRAY' or 'SCALAR'
+EOM
+ }
+
+ $fout->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 );
+
+ # Keep original modification time if no change (rt#145999)
+ my ( $read_time, $write_time ) = @input_file_stat[ 8, 9 ];
+ if ( !$self->[_input_output_difference_] && defined($write_time) ) {
+ utime( $read_time, $write_time, $input_file )
+ || Warn("error setting times for '$input_file'\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 $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;
+ }