File Coverage

blib/lib/File/AtomicWrite.pm

Criterion	Covered	Total	%
statement	157	221	71.0
branch	74	134	55.2
condition	22	48	45.8
subroutine	24	28	85.7
pod	8	8	100.0
total	285	439	64.9

# -*- Perl -*-
#
# 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. note however that
# rename() may not be safe depending on the filesystem and what
# exactly fails. run perldoc(1) on this file for more information

package File::AtomicWrite;

use strict;
use warnings;

use Carp qw(croak);
use Fcntl qw(:seek);
use File::Basename qw(dirname);
use File::Path qw(mkpath);
use File::Temp qw(tempfile);
# for olden versions of perl
use IO::Handle;

our $VERSION = '1.21';

# 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, $user_params ) = @_;
    $user_params = {} unless defined $user_params;

    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 = readline $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, $user_param ) = @_;
    $user_param = {} unless defined $user_param;

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

    my $self = {};

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

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

sub safe_level {
    my ( $class, $level ) = @_;
    croak 'safe_level() requires a value' unless defined $level;
    File::Temp->safe_level($level);
}

sub set_template {
    my ( $class, $template ) = @_;
    croak 'set_template() requires a template' unless defined $template;
    $default_params{template} = $template;
    return;
}

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

sub checksum {
    my ( $self, $csum ) = @_;
    croak 'checksum requires an argument' unless defined $csum;
    $self->{_params}->{checksum} = $csum;

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

    return $self;
}

sub commit { _resolve( @{ $_[0] }{qw/_tmp_fh _tmp_filename _params _digest/} ) }

sub DESTROY { _cleanup( @{ $_[0] }{qw/_tmp_fh _tmp_filename/} ) }

sub fh { $_[0]->{_tmp_fh} }

sub filename { $_[0]->{_tmp_filename} }

# for when 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) = @_;
    $user_params = {} unless defined $user_params;
    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) = @_;
    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, $tmp_filename, $params_ref, $digest ) = @_;

    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 (from a very old
    # version of XML::LibXML) 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, $directory ) = @_;

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

    return 1;
}

sub _check_checksum {
    my ( $tmp_fh, $checksum ) = @_;

    seek( $tmp_fh, 0, SEEK_SET )
      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, $min_size ) = @_;

    # 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, SEEK_END )
      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, $owner ) = @_;

    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;
}

1;
__END__