File Coverage

blib/lib/File/BackupCopy.pm
Criterion Covered Total %
statement 105 138 76.0
branch 33 56 58.9
condition 4 8 50.0
subroutine 19 21 90.4
pod 4 8 50.0
total 165 231 71.4


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