File Coverage

blib/lib/File/AtomicWrite.pm

Criterion	Covered	Total	%
statement	160	226	70.8
branch	67	122	54.9
condition	29	63	46.0
subroutine	23	27	85.1
pod	8	8	100.0
total	287	446	64.3

# -*- Perl -*-
#
# Like IO::AtomicWrite, except uses File::Temp to create the temporary
# file, and offers various degrees of more paranoid write handling, and
# means to set Unix file permissions and ownerships on the resulting
# file. Run perldoc(1) on this module for more information.

package File::AtomicWrite;

use strict;
use warnings;

use Carp qw/croak/;
use File::Basename qw/dirname/;
use File::Path qw/mkpath/;
use File::Temp qw/tempfile/;
use IO::Handle;

our $VERSION = '1.20';

# Default options
my %default_params = ( MKPATH => 0, template => ".tmp.XXXXXXXXXX" );

######################################################################
#
# Class methods

# Accepts output filename, perhaps optional tmp file template, and
# a filehandle or scalar ref, and handles all the details in a
# single shot.
sub write_file {
    my $class = shift;
    my $user_params = shift || {};

    if ( !exists $user_params->{input} ) {
        croak "missing 'input' option";
    }

    my ( $tmp_fh, $tmp_filename, $params_ref, $digest ) = _init($user_params);

    # Attempt cleanup if things go awry (use the OO interface and custom
    # signal handlers of your own if this is a problem)
    local $SIG{TERM} = sub { _cleanup( $tmp_fh, $tmp_filename ); exit };
    local $SIG{INT}  = sub { _cleanup( $tmp_fh, $tmp_filename ); exit };
    local $SIG{__DIE__} = sub { _cleanup( $tmp_fh, $tmp_filename ) };

    my $input_ref = ref $params_ref->{input};
    unless ( $input_ref eq 'SCALAR' or $input_ref eq 'GLOB' ) {
        croak "invalid type for input option: " . ref $input_ref;
    }

    my $input = $params_ref->{input};
    if ( $input_ref eq 'SCALAR' ) {
        unless ( print $tmp_fh $$input ) {
            my $save_errstr = $!;
            _cleanup( $tmp_fh, $tmp_filename );
            croak "error printing to temporary file: $save_errstr";
        }
        if ( exists $params_ref->{CHECKSUM}
            and !exists $params_ref->{checksum} ) {
            $digest->add($$input);
        }

    } elsif ( $input_ref eq 'GLOB' ) {
        while ( my $line = <$input> ) {
            unless ( print $tmp_fh $line ) {
                my $save_errstr = $!;
                _cleanup( $tmp_fh, $tmp_filename );
                croak "error printing to temporary file: $save_errstr";
            }

            if ( exists $params_ref->{CHECKSUM}
                and !exists $params_ref->{checksum} ) {
                $digest->add($$input);
            }
        }
    }

    _resolve( $tmp_fh, $tmp_filename, $params_ref, $digest );
}

sub new {
    my $class      = shift;
    my $self       = {};
    my $user_param = shift || {};

    croak "option 'input' only for write_file class method"
      if exists $user_param->{input};

    @{$self}{qw/_tmp_fh _tmp_filename _params _digest/} = _init($user_param);

    bless $self, $class;
    return $self;
}

sub safe_level {
    my $class = shift;
    my $level = shift || croak 'safe_level() requires a value';
    File::Temp->safe_level($level);
}

sub set_template {
    my $class = shift;
    my $template = shift || croak 'set_template() requires a template';
    $default_params{template} = $template;
    return;
}

######################################################################
#
# Instance methods

sub fh {
    shift->{_tmp_fh};
}

sub filename {
    shift->{_tmp_filename};
}

sub checksum {
    my $self = shift;
    $self->{_params}->{checksum} = shift
      || croak 'checksum requires an argument';

    if ( !$self->{_digest} ) {
        $self->{_params}->{CHECKSUM} = 1;
        $self->{_digest} = _init_checksum( $self->{_params} );
    }

    return $self;
}

sub commit {
    my $self = shift;
    _resolve( @{$self}{qw/_tmp_fh _tmp_filename _params _digest/} );
}

sub DESTROY {
    my $self = shift;
    _cleanup( @{$self}{qw/_tmp_fh _tmp_filename/} );
}

# For when (if) things go awry
sub _cleanup {
    my ( $tmp_fh, $tmp_filename ) = @_;
    # recommended by perlport(1) prior to unlink/rename calls
    close $tmp_fh if defined $tmp_fh;
    unlink $tmp_filename if defined $tmp_filename;
}

sub _init {
    my $user_params = shift || {};
    my $params_ref = { %default_params, %$user_params };

    if (   !exists $params_ref->{file}
        or !defined $params_ref->{file} ) {
        croak q{missing 'file' option};
    }

    my $digest = _init_checksum($params_ref);

    $params_ref->{_dir} = dirname( $params_ref->{file} );
    if ( !-d $params_ref->{_dir} ) {
        _mkpath( $params_ref->{MKPATH}, $params_ref->{_dir} );
    }

    if ( exists $params_ref->{tmpdir} ) {
        if ( !-d $params_ref->{tmpdir}
            and $params_ref->{tmpdir} ne $params_ref->{_dir} ) {
            _mkpath( $params_ref->{MKPATH}, $params_ref->{tmpdir} );

            # partition sanity check
            my @dev_ids = map { ( stat $params_ref->{$_} )[0] } qw/_dir tmpdir/;
            if ( $dev_ids[0] != $dev_ids[1] ) {
                croak 'tmpdir and file directory on different partitions';
            }
        }
    } else {
        $params_ref->{tmpdir} = $params_ref->{_dir};
    }

    if ( exists $params_ref->{safe_level} ) {
        File::Temp->safe_level( $params_ref->{safe_level} );
    }

    my ( $tmp_fh, $tmp_filename ) = tempfile(
        $params_ref->{template},
        DIR    => $params_ref->{tmpdir},
        UNLINK => 0
    );
    if ( !defined $tmp_fh ) {
        die "unable to obtain temporary filehandle\n";
    }

    if ( exists $params_ref->{binmode_layer}
        and defined $params_ref->{binmode_layer} ) {
        binmode( $tmp_fh, $params_ref->{binmode_layer} );
    } elsif ( exists $params_ref->{BINMODE} and $params_ref->{BINMODE} ) {
        binmode($tmp_fh);
    }

    return $tmp_fh, $tmp_filename, $params_ref, $digest;
}

sub _init_checksum {
    my $params_ref = shift;
    my $digest     = 0;

    if ( exists $params_ref->{CHECKSUM} and $params_ref->{CHECKSUM} ) {
        eval { require Digest::SHA1; };
        if ($@) {
            croak 'cannot checksum as lack Digest::SHA1';
        }
        $digest = Digest::SHA1->new;
    } else {
        # so can rely on 'exists' test elsewhere hereafter
        delete $params_ref->{CHECKSUM};
    }

    return $digest;
}

sub _resolve {
    my $tmp_fh       = shift;
    my $tmp_filename = shift;
    my $params_ref   = shift;
    my $digest       = shift;

    if ( exists $params_ref->{CHECKSUM}
        and !exists $params_ref->{checksum} ) {
        $params_ref->{checksum} = $digest->hexdigest;
    }

    # Help the bits reach the disk
    $tmp_fh->flush() or die "flush() error: $!\n";
    # TODO may need eval or exclude on other platforms
    if ( $^O !~ m/Win32/ ) {
        $tmp_fh->sync() or die "sync() error: $!\n";
    }

    eval {
        if ( exists $params_ref->{min_size} ) {
            _check_min_size( $tmp_fh, $params_ref->{min_size} );
        }
        if ( exists $params_ref->{CHECKSUM} ) {
            _check_checksum( $tmp_fh, $params_ref->{checksum} );
        }
    };
    if ($@) {
        _cleanup( $tmp_fh, $tmp_filename );
        die $@;
    }

    # recommended by perlport(1) prior to unlink/rename calls.
    #
    # TODO I've seen false positives from close() calls, though certain
    # file systems only report errors at close() time. If someone can
    # document a false positive, instead create an option and let the
    # caller decide.
    close($tmp_fh) or die "problem closing filehandle: $!\n";

    # spare subsequent useless close attempts, if any
    undef $tmp_fh;

    if ( exists $params_ref->{mode} ) {
        my $mode = $params_ref->{mode};
        croak 'invalid mode data'
          if !defined $mode
          or $mode !~ m/^[0-9]+$/;

        my $int_mode = substr( $mode, 0, 1 ) eq '0' ? oct($mode) : ( $mode + 0 );

        my $count = chmod( $int_mode, $tmp_filename );
        if ( $count != 1 ) {
            my $save_errstr = $!;
            _cleanup( $tmp_fh, $tmp_filename );
            die "unable to chmod temporary file: $save_errstr\n";
        }
    }

    if ( exists $params_ref->{owner} ) {
        eval { _set_ownership( $tmp_filename, $params_ref->{owner} ); };
        if ($@) {
            _cleanup( $tmp_fh, $tmp_filename );
            die $@;
        }
    }

    if ( exists $params_ref->{mtime} ) {
        croak 'invalid mtime data'
          if !defined $params_ref->{mtime}
          or $params_ref->{mtime} !~ m/^[0-9]+$/;

        my ($file_atime) = ( stat $tmp_filename )[8];
        my $count = utime( $file_atime, $params_ref->{mtime}, $tmp_filename );
        if ( $count != 1 ) {
            my $save_errstr = $!;
            _cleanup( $tmp_fh, $tmp_filename );
            die "unable to utime temporary file: $save_errstr\n";
        }
    }

    # If the file does not exist, but the backup does;
    # the backup is left unmodified
    if ( exists $params_ref->{backup} && -f $params_ref->{file} ) {
        croak 'invalid backup suffix'
          if !defined $params_ref->{backup}
          or $params_ref->{backup} eq '';

        # The backup file will be hardlinked in same directory as original
        my $backup_filename = $params_ref->{file} . $params_ref->{backup};
        if ( -f $backup_filename ) {
            my $count = unlink($backup_filename);
            if ( $count != 1 ) {
                my $save_errstr = $!;
                _cleanup( $tmp_fh, $tmp_filename );
                die "unable to unlink existing backup file: $save_errstr\n";
            }
        }

        # Make hardlink -- Haiku OS does not appear to support these;
        # http://www.cpantesters.org/cpan/report/7c2a3994-bc30-11e8-83ca-8681f4fbe649
        # which is warned about in the perlport POD
        if ( !link( $params_ref->{file}, $backup_filename ) ) {
            my $save_errstr = $!;
            _cleanup( $tmp_fh, $tmp_filename );
            die "unable to link existing file to backup file: $save_errstr\n";
        }
    }

    unless ( rename( $tmp_filename, $params_ref->{file} ) ) {
        my $save_errstr = $!;
        _cleanup( $tmp_fh, $tmp_filename );
        croak "unable to rename file: $save_errstr";
    }

    # spare subsequent useless unlink attempts, if any
    undef $tmp_filename;

    return 1;
}

sub _mkpath {
    my $mkpath    = shift;
    my $directory = shift;

    if ($mkpath) {
        mkpath($directory);
        if ( !-d $directory ) {
            croak "could not create parent directory";
        }
    } else {
        croak "parent directory does not exist";
    }

    return 1;
}

sub _check_checksum {
    my $tmp_fh   = shift;
    my $checksum = shift;

    seek( $tmp_fh, 0, 0 )
      or die("tmp fh seek() error: $!\n");

    my $digest = Digest::SHA1->new;
    $digest->addfile($tmp_fh);

    my $on_disk_checksum = $digest->hexdigest;

    if ( $on_disk_checksum ne $checksum ) {
        croak 'temporary file SHA1 hexdigest does not match supplied checksum';
    }

    return 1;
}

sub _check_min_size {
    my $tmp_fh   = shift;
    my $min_size = shift;

    # Must seek, as OO method allows the fh or filename to be passed off
    # and used by who knows what first.
    seek( $tmp_fh, 0, 2 )
      or die("tmp fh seek() error: $!\n");

    my $written = tell($tmp_fh);
    if ( $written == -1 ) {
        die("tmp fh tell() error: $!\n");
    } elsif ( $written < $min_size ) {
        croak 'bytes written failed to exceed min_size required';
    }

    return 1;
}

# Accepts "0" or "user:group" type ownership details and a filename,
# attempts to set ownership rights on that filename. croak()s if
# anything goes awry.
sub _set_ownership {
    my $filename = shift;
    my $owner    = shift;

    croak 'invalid owner data' if !defined $owner or length $owner < 1;

    # defaults if nothing comes of the subsequent parsing
    my ( $uid, $gid ) = ( -1, -1 );

    my ( $user_name, $group_name ) = split /[:.]/, $owner, 2;

    my ( $login, $pass, $user_uid, $user_gid );

    # Only customize user if have something from caller
    if ( defined $user_name and $user_name ne '' ) {
        if ( $user_name =~ m/^([0-9]+)$/ ) {
            $uid = $1;
        } else {
            ( $login, $pass, $user_uid, $user_gid ) = getpwnam($user_name)
              or croak 'user not in password database';
            $uid = $user_uid;
        }
    }

    # Only customize group if have something from caller
    if ( defined $group_name and $group_name ne '' ) {
        if ( $group_name =~ m/^([0-9]+)$/ ) {
            $gid = $1;
        } else {
            my ( $group_name, $pass, $group_gid ) = getgrnam($group_name)
              or croak 'group not in group database';
            $gid = $group_gid;
        }
    }

    my $count = chown( $uid, $gid, $filename );
    if ( $count != 1 ) {
        die "unable to chown temporary file\n";
    }

    return 1;
}

42;
__END__