File Coverage

lib/App/MtAws/IntermediateFile.pm

Criterion	Covered	Total	%
statement	62	64	96.8
branch	18	24	75.0
condition	6	9	66.6
subroutine	14	14	100.0
pod	0	3	0.0
total	100	114	87.7

# mt-aws-glacier - Amazon Glacier sync client
# Copyright (C) 2012-2014  Victor Efimov
# http://mt-aws.com (also http://vs-dev.com) [e-mail]
# License: GPLv3
#
# This file is part of "mt-aws-glacier"
#
#    mt-aws-glacier is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    mt-aws-glacier is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

package App::MtAws::IntermediateFile;

our $VERSION = '1.114_2';

use strict;
use warnings;
use utf8;
use Carp;
use File::Temp 0.16 ();
use File::Path;
use File::Basename;
use App::MtAws::Utils;
use App::MtAws::Exceptions;


sub new
{
	my ($class, %args) = @_;
	my $self = {};
	defined ($self->{target_file} = delete $args{target_file}) or confess "target_file expected";
	$self->{mtime} = delete $args{mtime};
	confess "unknown arguments" if %args;
	bless $self, $class;
	$self->_init();
	$self->{_init_pid} = $$;
	return $self;
}

sub _init
{
	my ($self) = @_;
	my $dir  = dirname($self->{target_file});
	my $binary_dirname = binaryfilename $dir;
	eval { mkpath($binary_dirname); 1 } or do {
		die exception 'cannot_create_directory' =>
		'Cannot create directory %string dir%, errors: %error%',
		dir => $dir, error => hex_dump_string($@);
	};
	$self->{tmp} = eval {
		# PID is needed cause child processes re-use random number generators, improves performance only, no risk of race cond.
		File::Temp->new(TEMPLATE => "__mtglacier_temp${$}_XXXXXX", UNLINK => 1, SUFFIX => '.tmp', DIR => $binary_dirname)
	} or do {
		die exception 'cannot_create_tempfile' =>
		'Cannot create temporary file in directory %string dir%, errors: %error%',
		dir => $dir, error => hex_dump_string($@);
	};
	my $binary_tempfile = $self->{tmp}->filename;
	$self->{tempfile} = characterfilename($binary_tempfile);
	 # it's important to close file, it's filename can be passed to different process, and it can be locked
	close $self->{tmp} or confess;
}

sub tempfilename
{
	shift->{tempfile} or confess;
}

sub make_permanent
{
	my $self = shift;
	confess "unknown arguments" if @_;
	my $binary_target_filename = binaryfilename($self->{target_file});

	my $character_tempfile = delete $self->{tempfile} or confess "file already permanent or not initialized";
	$self->{tmp}->unlink_on_destroy(0);
	undef $self->{tmp};
	my $binary_tempfile = binaryfilename($character_tempfile);

	chmod((0666 & ~umask), $binary_tempfile) or confess "cannot chmod file $character_tempfile";
	utime $self->{mtime}, $self->{mtime}, $binary_tempfile or confess "cannot change mtime for $character_tempfile" if defined $self->{mtime};
	rename $binary_tempfile, $binary_target_filename or
		die exception "cannot_rename_file" => "Cannot rename file %string from% to %string to%",
		from => $character_tempfile, to => $self->{target_file};
}

# File::Temp < 0.19 does not have protection from calling destructor in fork'ed child
# and forking can happen any moments, some code in File::Spec/Cwd etc call it to exec external commands
# this workaround prevents this, however destruction order is undefined so that might just fail

# we can try use File::Temp::tempfile() but it destroys temp files only on program exit
# (can workaround with DESTROY) + when handle is closed! (thats bad)
sub DESTROY
{
	my ($self) = @_;
	local ($!, $@, $?);
	eval { $self->{tmp}->unlink_on_destroy(0) }
		if ($self->{_init_pid} && $self->{_init_pid} != $$ && $self->{tmp});
}

1;