File Coverage

blib/lib/File/BackupCopy.pm
Criterion Covered Total %
statement 104 136 76.4
branch 31 56 55.3
condition 4 11 36.3
subroutine 19 21 90.4
pod 4 8 50.0
total 162 232 69.8


line stmt bran cond sub pod time code
1             package File::BackupCopy;
2 5     5   133137 use strict;
  5         22  
  5         148  
3 5     5   23 use warnings;
  5         7  
  5         132  
4 5     5   1976 use File::Copy;
  5         9488  
  5         226  
5 5     5   29 use File::Temp 'tempfile';
  5         9  
  5         154  
6 5     5   23 use File::Basename;
  5         8  
  5         385  
7 5     5   1347 use File::Spec;
  5         7  
  5         75  
8 5     5   21 use Exporter;
  5         6  
  5         173  
9 5     5   23 use re '/aa';
  5         7  
  5         221  
10 5     5   23 use Carp;
  5         9  
  5         252  
11 5     5   31 use Errno;
  5         13  
  5         480  
12              
13             our $VERSION = '1.01';
14             our @ISA = qw(Exporter);
15             our @EXPORT = qw(BACKUP_NONE
16             BACKUP_SINGLE
17             BACKUP_SIMPLE
18             BACKUP_NUMBERED
19             BACKUP_AUTO
20             backup_copy);
21              
22             our @EXPORT_OK = qw(backup_copy_simple backup_copy_numbered backup_copy_auto);
23              
24             use constant {
25 5         4564 BACKUP_NONE => 0, # No backups at all (none,off)
26             BACKUP_SINGLE => 1, # Always make single backups (never,simple)
27             BACKUP_SIMPLE => 1,
28             BACKUP_NUMBERED => 2, # Always make numbered backups (t,numbered)
29             BACKUP_AUTO => 3 # Make numbered if numbered backups exist,
30             # simple otherwise (nil,existing)
31 5     5   28 };
  5         6  
32              
33             my %envtrans = (
34             none => BACKUP_NONE,
35             off => BACKUP_NONE,
36             never => BACKUP_SIMPLE,
37             simple => BACKUP_SIMPLE,
38             t => BACKUP_NUMBERED,
39             numbered => BACKUP_NUMBERED,
40             nil => BACKUP_AUTO,
41             existing => BACKUP_AUTO
42             );
43              
44             my %backup_func = (
45             BACKUP_NONE() => sub {},
46             BACKUP_SIMPLE() => \&backup_copy_simple,
47             BACKUP_NUMBERED() => \&backup_copy_numbered,
48             BACKUP_AUTO() => \&backup_copy_auto
49             );
50              
51             sub backup_copy {
52 22     22 1 6174 my $file = shift;
53              
54 22         29 my ($type, %opts);
55 22 100       63 if (@_ == 1) {
    50          
56 5         8 $type = shift;
57             } elsif (@_ % 2 == 0) {
58 17         37 %opts = @_;
59 17         28 $type = delete $opts{type};
60             } else {
61 0         0 croak "wrong number of arguments";
62             }
63              
64 22 100       47 unless (defined($type)) {
65 12   100     32 my $v = $ENV{VERSION_CONTROL} || BACKUP_AUTO;
66 12 100       19 if (exists($envtrans{$v})) {
67 9         15 $type = $envtrans{$v};
68             } else {
69 3         5 $type = BACKUP_AUTO;
70             }
71             }
72 22         33 &{$backup_func{$type}}($file, %opts);
  22         49  
73             }
74              
75             sub _backup_copy_error {
76 8     8   952 my ($error, $msg) = @_;
77 8 100       21 if ($error) {
78 4         10 $$error = $msg;
79 4         19 return undef;
80             }
81 4         1011 confess $msg;
82             }
83              
84             sub backup_copy_simple {
85 20     20 1 1497 my $file_name = shift;
86 20         64 local %_ = @_;
87 20         43 my $error = delete $_{error};
88 20         32 my $dir = delete $_{dir};
89 20 50       51 croak "unrecognized keyword arguments" if keys %_;
90 20         34 my $backup_name = $file_name . '~';
91 20 100       37 if ($dir) {
92 11         320 $backup_name = File::Spec->catfile($dir, basename($backup_name));
93             }
94 20 100       61 copy($file_name, $backup_name)
95             or return _backup_copy_error($error,
96             "failed to copy $file_name to $backup_name: $!");
97 14         3447 return $backup_name;
98             }
99              
100             sub backup_copy_internal {
101 27     27 0 40 my $file_name = shift;
102              
103 27         36 my ($if_exists, $error, $dir);
104 27 50       88 if (@_ == 1) {
    50          
105 0         0 $if_exists = shift;
106             } elsif (@_ % 2 == 0) {
107 27         63 local %_ = @_;
108 27         48 $if_exists = delete $_{if_exists};
109 27         38 $error = delete $_{error};
110 27         51 $dir = delete $_{dir};
111 27 50       90 croak "unrecognized keyword arguments" if keys %_;
112             } else {
113 0         0 croak "wrong number of arguments";
114             }
115            
116 27 100       396 my $backup_stub = $dir ? File::Spec->catfile($dir, basename($file_name))
117             : $file_name;
118 4         13 my $num = (sort { $b <=> $a }
119             map {
120 27 50       1234 if (/.+\.~(\d+)~$/) {
  13         75  
121 13         63 $1
122             } else {
123             ()
124 0         0 }
125             } glob("$backup_stub.~*~"))[0];
126              
127 27 100       85 if (defined($num)) {
128 9         15 ++$num;
129             } else {
130 18 100       53 return backup_copy_simple($file_name, error => $error, dir => $dir)
131             if $if_exists;
132 8         14 $num = '1';
133             }
134            
135 17   66     27 my ($fh, $tempname) = eval { tempfile(DIR => $dir || dirname($file_name)) };
  17         477  
136 17 100       4464 if ($@) {
137 2         7 return _backup_copy_error($error, $@);
138             }
139              
140 15 50       47 copy($file_name, $fh)
141             or return _backup_copy_error($error,
142             "failed to make a temporary copy of $file_name: $!");
143 15         2410 close $fh;
144            
145 15         58 my $backup_name = rename_backup($tempname, $backup_stub, $num, $error);
146 15 50       44 unless ($backup_name) {
147 0 0       0 unlink($tempname) or carp("can't unlink $tempname: $!");
148             }
149 15         85 return $backup_name;
150             }
151              
152             # The rename_backup function performs the final stage of numbered backup
153             # creation: atomical rename of the temporary backup file to the actual
154             # backup name.
155             # The calling sequence is:
156             # rename_backup($tempfile, $backup_stub, $num, $error)
157             # where $tempfile is the name of the temporary file holding the backup,
158             # $backup_stub is the name of the backup file without the actual
159             # numbered suffix (may contain directory components,
160             # if required).
161             # $num is the first unused backup number,
162             # $error is the reference to error message storage or undef.
163             # The function creates the new backup file name from $backup_stub and
164             # $num and attempts to rename $tempfile to it. If the rename failed
165             # because such file already exists (i.e. another process created it in
166             # between), the function increases the $num and retries. The process
167             # continues until the rename succeeds or a fatal error is encountered,
168             # whichever occurs first.
169             #
170             # Three versions of the function are provided. The right one to use
171             # is selected when the module is loaded:
172              
173             BEGIN {
174 5 50 0 5   17 if (eval { symlink("",""); 1 }) {
  5 0       48  
  5         22  
175 5         2259 *{rename_backup} = \&rename_backup_posix;
176 0         0 } elsif ($^O eq 'MSWin32' && eval { require Win32API::File }) {
177 0         0 Win32API::File->import(qw(MoveFile fileLastError));
178 0         0 *{rename_backup} = \&rename_backup_win32;
179             } else {
180 0         0 warn "using last resort rename method susceptible to a race condition";
181 0         0 *{rename_backup} = \&rename_backup_last_resort;
182             }
183             }
184              
185             # rename_backup_posix - rename_backup for POSIX systems.
186             # -------------------
187             # In order to ensure atomic rename, the temporary file is first
188             # symlinked to the desired backup name. This will fail if the
189             # name already exists, in which case the function will try next
190             # backup number. Once the symlink is created, temporary file
191             # is renamed to it. This operation will silently destroy the
192             # symlink and replace it with the backup file.
193             sub rename_backup_posix {
194 15     15 0 41 my ($tempfilename, $backup_stub, $num, $error) = @_;
195 15         19 my $backup_name;
196 15         17 while (1) {
197 15         31 $backup_name = "$backup_stub.~$num~";
198 15 50       413 last if symlink($tempfilename, $backup_name);
199 0 0       0 unless ($!{EEXIST}) {
200 0         0 return _backup_copy_error($error,
201             "can't link $tempfilename to $backup_name: $!");
202             }
203 0         0 ++$num;
204             }
205            
206 15 50       954 unless (rename($tempfilename, $backup_name)) {
207 0         0 return _backup_copy_error($error,
208             "can't rename temporary file to $backup_name: $!");
209             }
210 15         74 return $backup_name;
211             }
212              
213             # rename_backup_win32 - rename_backup for MSWin32 systems with Win32API::File
214             # -------------------
215             # This function is used if Win32API::File was loaded successfully. It uses
216             # the MoveFile function to ensure atomic renames.
217             sub rename_backup_win32 {
218 0     0 0 0 my ($tempfilename, $backup_stub, $num, $error) = @_;
219 0         0 my $backup_name;
220 0         0 while (1) {
221 0         0 $backup_name = "$backup_stub.~$num~";
222 0 0       0 last if MoveFile($tempfilename, $backup_name);
223             # 80 - ERROR_FILE_EXISTS
224             # - "The file exists."
225             # 183 - ERROR_ALREADY_EXISTS
226             # - "Cannot create a file when that file already exists."
227 0 0 0     0 unless (fileLastError() == 80 || fileLastError() == 183) {
228 0         0 return _backup_copy_error($error,
229             "can't rename $tempfilename to $backup_name: $^E");
230             }
231 0         0 ++$num;
232             }
233 0         0 return $backup_name;
234             }
235              
236             # rename_backup_last_resort - a weaker version for the rest of systems
237             # -------------------------
238             # It is enabled on systems not offering the symlink function (except where
239             # Win32API::File can be used). This version uses a combination of -f test
240             # and rename. It suffers from an obvious race condition which occurs in
241             # the time window between these.
242             sub rename_backup_last_resort {
243 0     0 0 0 my ($tempfilename, $backup_stub, $num, $error) = @_;
244 0         0 my $backup_name;
245 0         0 while (1) {
246 0         0 $backup_name = "$backup_stub.~$num~";
247 0 0       0 unless (-f $backup_name) {
248 0 0       0 last if rename($tempfilename, $backup_name);
249 0         0 return _backup_copy_error($error,
250             "can't rename temporary file to $backup_name: $!");
251             }
252 0         0 ++$num;
253             }
254 0         0 return $backup_name;
255             }
256              
257             sub backup_copy_numbered {
258 10     10 1 1940 my ($file_name, %opts) = @_;
259 10         21 $opts{if_exists} = 0;
260 10         32 backup_copy_internal($file_name, %opts);
261             }
262              
263             sub backup_copy_auto {
264 17     17 1 2158 my ($file_name, %opts) = @_;
265 17         32 $opts{if_exists} = 1;
266 17         58 backup_copy_internal($file_name, %opts);
267             }
268            
269             1;
270             __END__