File Coverage

blib/lib/IO/File/AtomicChange.pm
Criterion Covered Total %
statement 77 92 83.7
branch 24 44 54.5
condition 3 3 100.0
subroutine 17 20 85.0
pod 2 8 25.0
total 123 167 73.6


line stmt bran cond sub pod time code
1             package IO::File::AtomicChange;
2              
3 7     7   570635 use strict;
  7         63  
  7         163  
4 7     7   28 use warnings;
  7         11  
  7         241  
5              
6             our $VERSION = '0.07_02';
7              
8 7     7   36 use base qw(IO::File);
  7         11  
  7         920  
9 7     7   6259 use Carp;
  7         26  
  7         382  
10 7     7   619 use File::Temp qw(:mktemp);
  7         10140  
  7         981  
11 7     7   2961 use File::Copy;
  7         13249  
  7         5747  
12              
13             sub new {
14 20     20 1 14061 my $class = shift;
15 20         87 my $self = $class->SUPER::new();
16 20         585 $self->_temp_file("");
17 20         51 $self->_target_file("");
18 20         49 $self->_backup_dir("");
19 20 50       69 $self->open(@_) if @_;
20 20         1607 $self;
21             }
22              
23             sub _accessor {
24 174     174   262 my($self, $tag, $val) = @_;
25 174 100       295 ${*$self}{$tag} = $val if $val;
  44         143  
26 174         188 return ${*$self}{$tag};
  174         1643  
27             }
28 59     59   108 sub _temp_file { return shift->_accessor("io_file_atomicchange_temp", @_) }
29 69     69   111 sub _target_file { return shift->_accessor("io_file_atomicchange_path", @_) }
30 46     46   88 sub _backup_dir { return shift->_accessor("io_file_atomicchange_back", @_) }
31              
32             sub DESTROY {
33 20 100   20   1419 carp "[CAUTION] disposed object without closing file handle." unless $_[0]->_closed;
34             }
35              
36             sub open {
37 20     20 1 40 my ($self, $path, $mode, $opt) = @_;
38 20 50       39 ref($self) or $self = $self->new;
39              
40             # Because we do rename(2) atomically, temporary file must be in same
41             # partion with target file.
42 20         83 my $temp = mktemp("${path}.XXXXXX");
43 20         3039 $self->_temp_file($temp);
44 20         50 $self->_target_file($path);
45              
46 20 100       239 copy_preserving_attr($path, $temp) if -f $path;
47 20 100       60 if (exists $opt->{backup_dir}) {
48 4 50       40 unless (-d $opt->{backup_dir}) {
49 0         0 croak "no such directory: $opt->{backup_dir}";
50             }
51 4         13 $self->_backup_dir($opt->{backup_dir});
52             }
53              
54 20 50       86 $self->SUPER::open($temp, $mode) ? $self : undef;
55             }
56              
57             sub _closed {
58 39     39   63 my $self = shift;
59 39         55 my $tag = "io_file_atomicchange_closed";
60              
61 39         61 my $oldval = ${*$self}{$tag};
  39         117  
62 39 100       124 ${*$self}{$tag} = shift if @_;
  19         48  
63 39         368 return $oldval;
64             }
65              
66             sub close {
67 19     19 0 523 my ($self, $die) = @_;
68 19 50       44410 $self->sync() or croak "sync: $!";
69 19 50       123 unless ($self->_closed(1)) {
70 19 50       88 if ($self->SUPER::close()) {
71              
72 19 100 100     1001 $self->backup if ($self->_backup_dir && -f $self->_target_file);
73              
74 19 0       42 rename($self->_temp_file, $self->_target_file)
    50          
75             or ($die ? croak "close (rename) atomic file: $!\n" : return);
76             } else {
77 0 0       0 $die ? croak "close atomic file: $!\n" : return;
78             }
79             }
80 19         88 1;
81             }
82              
83             sub copy_modown_to_temp {
84 0     0 0 0 my($self) = @_;
85              
86 0         0 my($mode, $uid, $gid) = (stat($self->_target_file))[2,4,5];
87 0         0 chown $uid, $gid, $self->_temp_file;
88 0         0 chmod $mode, $self->_temp_file;
89             }
90              
91             sub backup {
92 3     3 0 6 my($self) = @_;
93              
94 3         19 require Path::Class;
95 3         846 require POSIX;
96 3         8070 require Time::HiRes;
97              
98 3         1868 my $basename = Path::Class::file($self->_target_file)->basename;
99              
100 3         287 my $backup_file;
101 3         5 my $n = 0;
102 3         8 while ($n < 7) {
103 3 50       16 $backup_file = sprintf("%s/%s_%s.%d_%d%s",
104             $self->_backup_dir,
105             $basename,
106             POSIX::strftime("%Y-%m-%d_%H%M%S",localtime()),
107             (Time::HiRes::gettimeofday())[1],
108             $$,
109             ($n == 0 ? "" : ".$n"),
110             );
111 3 50       73 last unless -f $backup_file;
112 0         0 $n++;
113             }
114 3 50       28 croak "already exists backup file: $backup_file" if -f $backup_file;
115              
116 3         10 copy_preserving_attr($self->_target_file, $backup_file);
117             }
118              
119              
120             sub delete {
121 0     0 0 0 my $self = shift;
122 0 0       0 unless ($self->_closed(1)) {
123 0         0 $self->SUPER::close();
124 0         0 return unlink($self->_temp_file);
125             }
126 0         0 1;
127             }
128              
129             sub detach {
130 0     0 0 0 my $self = shift;
131 0 0       0 $self->SUPER::close() unless ($self->_closed(1));
132 0         0 1;
133             }
134              
135             sub copy_preserving_attr {
136 15     15 0 37 my($from, $to) = @_;
137              
138 15 50       52 File::Copy::copy($from, $to) or croak $!;
139              
140 15         3642 my($mode, $uid, $gid, $atime, $mtime) = (stat($from))[2,4,5,8,9];
141 15         277 chown $uid, $gid, $to;
142 15         200 chmod $mode, $to;
143 15         204 utime $atime, $mtime, $to;
144 15         41 1;
145             }
146              
147              
148             1;
149             __END__