summaryrefslogtreecommitdiffabout
authorSergey Poznyakoff <gray@gnu.org>2020-01-27 05:21:29 (GMT)
committer Sergey Poznyakoff <gray@gnu.org>2020-01-27 05:26:33 (GMT)
commitcafe11d43e7d1fb298acb0e5c78f97b8c808b4a3 (patch) (side-by-side diff)
tree0e73e154bd1f24cfa8686fa4c1eb8b7c92f73dc6
parentf3d76da04b7e918c104693b8584c4f4bd18a7c8d (diff)
downloadfile-backup-cafe11d43e7d1fb298acb0e5c78f97b8c808b4a3.tar.gz
file-backup-cafe11d43e7d1fb298acb0e5c78f97b8c808b4a3.tar.bz2
Various improvements; support for MSWin32v1.01
* Makefile.PL: Minimal Perl version 5.14.2 When building on MSWin32, require Win32API::File. * lib/File/BackupCopy.pm: Provide three different versions of the rename_backup function: for POSIX systems, for MSWin32 and a fallback for systems not falling into either category. * t/TestBackup.pm: Minor change in import.
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--Changes5
-rw-r--r--Makefile.PL13
-rw-r--r--lib/File/BackupCopy.pm136
-rw-r--r--t/TestBackup.pm3
4 files changed, 137 insertions, 20 deletions
diff --git a/Changes b/Changes
index 4dda3a6..4aeca71 100644
--- a/Changes
+++ b/Changes
@@ -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 {

Return to:

Send suggestions and report system problems to the System administrator.