diff options
-rw-r--r-- | Changes | 5 | ||||
-rw-r--r-- | Makefile.PL | 13 | ||||
-rw-r--r-- | lib/File/BackupCopy.pm | 136 | ||||
-rw-r--r-- | t/TestBackup.pm | 3 |
4 files changed, 137 insertions, 20 deletions
@@ -1,4 +1,7 @@ -Revision history for Perl extension File::BackupCopy +Revision history for Perl extension File::BackupCopy. + +1.01 2020-01-27 + - Fix portability issues. 1.00 2020-01-20 - Initial release. diff --git a/Makefile.PL b/Makefile.PL index 1947389..12e6b33 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,13 +3,13 @@ use warnings; use ExtUtils::MakeMaker; use Module::Metadata; -WriteMakefile( +my %makefile_args = ( NAME => 'File::BackupCopy', VERSION_FROM => 'lib/File/BackupCopy.pm', ABSTRACT_FROM => 'lib/File/BackupCopy.pm', LICENSE => 'gpl_3', AUTHOR => 'Sergey Poznyakoff <gray@gnu.org>', - MIN_PERL_VERSION => 5.006, + MIN_PERL_VERSION => 5.014002, PREREQ_PM => { 'File::Temp' => 0.23 }, @@ -30,5 +30,12 @@ WriteMakefile( } ); - +unless (eval { symlink("",""); 1 }) { + if ($^O eq 'MSWin32') { + $makefile_args{PREREQ_PM}{'Win32API::File'} = 0.1203; + } +} + +WriteMakefile(%makefile_args); + diff --git a/lib/File/BackupCopy.pm b/lib/File/BackupCopy.pm index fd52029..1d0eb07 100644 --- a/lib/File/BackupCopy.pm +++ b/lib/File/BackupCopy.pm @@ -2,7 +2,7 @@ package File::BackupCopy; use strict; use warnings; use File::Copy; -use File::Temp; +use File::Temp 'tempfile'; use File::Basename; use File::Spec; use Exporter; @@ -10,7 +10,7 @@ use re '/aa'; use Carp; use Errno; -our $VERSION = '1.00'; +our $VERSION = '1.01'; our @ISA = qw(Exporter); our @EXPORT = qw(BACKUP_NONE BACKUP_SINGLE @@ -124,37 +124,133 @@ sub backup_copy_internal { } } glob("$backup_stub.~*~"))[0]; - if (!defined($num)) { + if (defined($num)) { + ++$num; + } else { return backup_copy_simple($file_name, error => $error, dir => $dir) if $if_exists; $num = '1'; } - my $fh = eval { File::Temp->new(DIR => $dir || dirname($file_name)) }; + my ($fh, $tempname) = eval { tempfile(DIR => $dir || dirname($file_name)) }; if ($@) { return _backup_copy_error($error, $@); } copy($file_name, $fh) or return _backup_copy_error($error, - "failed to make a temporary copy of $file_name: $!"); + "failed to make a temporary copy of $file_name: $!"); + close $fh; + + my $backup_name = rename_backup($tempname, $backup_stub, $num, $error); + unless ($backup_name) { + unlink($tempname) or carp("can't unlink $tempname: $!"); + } + return $backup_name; +} + +# The rename_backup function performs the final stage of numbered backup +# creation: atomical rename of the temporary backup file to the actual +# backup name. +# The calling sequence is: +# rename_backup($tempfile, $backup_stub, $num, $error) +# where $tempfile is the name of the temporary file holding the backup, +# $backup_stub is the name of the backup file without the actual +# numbered suffix (may contain directory components, +# if required). +# $num is the first unused backup number, +# $error is the reference to error message storage or undef. +# The function creates the new backup file name from $backup_stub and +# $num and attempts to rename $tempfile to it. If the rename failed +# because such file already exists (i.e. another process created it in +# between), the function increases the $num and retries. The process +# continues until the rename succeeds or a fatal error is encountered, +# whichever occurs first. +# +# Three versions of the function are provided. The right one to use +# is selected when the module is loaded: + +BEGIN { + if (eval { symlink("",""); 1 }) { + *{rename_backup} = \&rename_backup_posix; + } elsif ($^O eq 'MSWin32' && eval { require Win32API::File }) { + Win32API::File->import(qw(MoveFile fileLastError)); + *{rename_backup} = \&rename_backup_win32; + } else { + warn "using last resort rename method susceptible to a race condition"; + *{rename_backup} = \&rename_backup_last_resort; + } +} +# rename_backup_posix - rename_backup for POSIX systems. +# ------------------- +# In order to ensure atomic rename, the temporary file is first +# symlinked to the desired backup name. This will fail if the +# name already exists, in which case the function will try next +# backup number. Once the symlink is created, temporary file +# is renamed to it. This operation will silently destroy the +# symlink and replace it with the backup file. +sub rename_backup_posix { + my ($tempfilename, $backup_stub, $num, $error) = @_; my $backup_name; while (1) { $backup_name = "$backup_stub.~$num~"; - last if symlink($fh->filename, $backup_name); + last if symlink($tempfilename, $backup_name); unless ($!{EEXIST}) { - return _backup_copy_error("can't link " - . $fh->filename . - " to $backup_name: $!"); + return _backup_copy_error($error, + "can't link $tempfilename to $backup_name: $!"); } ++$num; } - unless (rename($fh->filename, $backup_name)) { - return _backup_copy_error("can't rename temporary file to $backup_name: $!"); + unless (rename($tempfilename, $backup_name)) { + return _backup_copy_error($error, + "can't rename temporary file to $backup_name: $!"); + } + return $backup_name; +} + +# rename_backup_win32 - rename_backup for MSWin32 systems with Win32API::File +# ------------------- +# This function is used if Win32API::File was loaded successfully. It uses +# the MoveFile function to ensure atomic renames. +sub rename_backup_win32 { + my ($tempfilename, $backup_stub, $num, $error) = @_; + my $backup_name; + while (1) { + $backup_name = "$backup_stub.~$num~"; + last if MoveFile($tempfilename, $backup_name); + # 80 - ERROR_FILE_EXISTS + # - "The file exists." + # 183 - ERROR_ALREADY_EXISTS + # - "Cannot create a file when that file already exists." + unless (fileLastError() == 80 || fileLastError() == 183) { + return _backup_copy_error($error, + "can't rename $tempfilename to $backup_name: $^E"); + } + ++$num; + } + return $backup_name; +} + +# rename_backup_last_resort - a weaker version for the rest of systems +# ------------------------- +# It is enabled on systems not offering the symlink function (except where +# Win32API::File can be used). This version uses a combination of -f test +# and rename. It suffers from an obvious race condition which occurs in +# the time window between these. +sub rename_backup_last_resort { + my ($tempfilename, $backup_stub, $num, $error) = @_; + my $backup_name; + while (1) { + $backup_name = "$backup_stub.~$num~"; + unless (-f $backup_name) { + last if rename($tempfilename, $backup_name); + return _backup_copy_error($error, + "can't rename temporary file to $backup_name: $!"); + } + ++$num; } - $fh->unlink_on_destroy(0); return $backup_name; } @@ -332,5 +428,17 @@ the file. Otherwise, creates simple backup. Optional I<%opts> have the same meaning as in B<backup_copy>, except that, obviously, B<type> keyword is not accepted. - -=cut + +=head1 LICENSE + +GPLv3+: GNU GPL version 3 or later, see +L<http://gnu.org/licenses/gpl.html>. + +This is free software: you are free to change and redistribute it. +There is NO WARRANTY, to the extent permitted by law. + +=head1 AUTHORS + +Sergey Poznyakoff <gray@gnu.org> + +=cut diff --git a/t/TestBackup.pm b/t/TestBackup.pm index 72e5925..62ca43f 100644 --- a/t/TestBackup.pm +++ b/t/TestBackup.pm @@ -10,12 +10,11 @@ our @ISA = qw(Test); our @EXPORT=qw(makefile fileok plan ok); sub import { - my $pkg = shift; my $workdir = tempdir(CLEANUP => 1); chdir($workdir) or croak "can't change to $workdir: $!"; @pattern = grep { /[\w\d]+/ } map { chr($_) } (1..127); delete $ENV{VERSION_CONTROL}; - $pkg->export_to_level(1, @_); + $_[0]->export_to_level(1, @_); } sub makefile { |