File::AtomicWrite - writes files atomically via rename()

  use File::AtomicWrite ();

  # Standalone method: requires filename and
  # input data (filehandle or scalar ref)
  File::AtomicWrite->write_file(
    { file  => 'data.dat',
      input => $filehandle
    }
  );

  # how paranoid are you?
  File::AtomicWrite->write_file(
    { file     => '/etc/passwd',
      input    => \$scalarref,
      CHECKSUM => 1,
      min_size => 100
    }
  );

  # OO interface
  my $aw = File::AtomicWrite->new(
    { file     => 'name',
      min_size => 100,
      ...
    }
  );

  my $tmp_fh   = $aw->fh;
  my $tmp_file = $aw->filename;

  print $tmp_fh ...

  $aw->checksum($sha1_hexdigest);
  $aw->commit;

  eval {
    File::AtomicWrite->write_file(...);
  };
  if ($@) {
    die "uh oh: $@";
  }

  % touch afile
  % ln afile afilehardlink
  % ls -i afile*          
  3725607 afile		3725607 afilehardlink
  % perl -MFile::AtomicWrite -e \
    'File::AtomicWrite->write_file({file =>"afile",input=>\"foo"})' 
  % ls -i afile*
  3725622 afile		3725607 afilehardlink

# -*- 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.
#
# Copyright 2009-2010 by Jeremy Mates.
#
# This module is free software; you can redistribute it and/or modify it
# under the Artistic license.

package File::AtomicWrite;

use strict;
use warnings;

require 5.006;

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.03';

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

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

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

  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\n");
    }
    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\n");
      }

      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("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\n");
      }
    }
  } 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\n");
    }
    $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} ) {
    croak("invalid mode data\n")
      if !defined $params_ref->{mode}
        or $params_ref->{mode} !~ m/^\d+$/;

    my $count = chmod( $params_ref->{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 $@;
    }
  }

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

  # 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\n");
    }
  } else {
    croak("parent directory does not exist\n");
  }

  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\n");
  }

  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\n");
  }

  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\n") 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 );
  if ( $user_name =~ m/^(\d+)$/ ) {
    $uid = $1;
  } else {
    ( $login, $pass, $user_uid, $user_gid ) = getpwnam($user_name)
      or croak("user not in password database\n");
    $uid = $user_uid;
  }

  # Only customize group if have something from caller
  if ( defined $group_name ) {
    if ( $group_name =~ m/^(\d+)$/ ) {
      $gid = $group_name;
    } else {
      my ( $group_name, $pass, $group_gid ) = getgrnam($group_name)
        or croak("group not in group database\n");
      $gid = $group_gid;
    }
  }

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

  return 1;
}

1;

__END__