view release on metacpan or  search on metacpan

lib/Perl/Tidy.pm  view on Meta::CPAN

    #---------------------------------------------------------
    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: $OS_ERROR\n"
              );
        }
    }

    return;

} ## end sub backup_method_move

# masks for file permissions
use constant OCT_777  => oct(777);     # All users (O+G+W) + r/w/x bits
use constant OCT_7777 => oct(7777);    # Same + suid/sgid/sbit
use constant OCT_600  => oct(600);     # Owner RW permission

sub set_output_file_permissions {

    my ( $self, $output_file, $rinput_file_stat, $in_place_modify ) = @_;

    # Set the permissions for the output file

    # 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}[ _mode_, _uid_, _gid_ ];
    my ( $uid_o, $gid_o ) = ( stat($output_file) )[ _uid_, _gid_ ];
    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 ) = @_;

    # Decode the input buffer from utf8 if necessary or requested

    # Given:
    #   $input_file   = the input file or stream
    #   $display_name = its name to use in error messages

    # Set $self->[_line_separator_], and

    # Return:
    #   $rinput_string = ref to input string, decoded from utf8 if necessary
    #   $is_encoded_data  = true if $buf is decoded from utf8
    #   $decoded_input_as = true if perltidy decoded input buf