File Coverage

blib/lib/No/Worries/Stat.pm
Criterion Covered Total %
statement 151 186 81.1
branch 25 68 36.7
condition 5 18 27.7
subroutine 30 32 93.7
pod 2 2 100.0
total 213 306 69.6


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/Stat.pm #
4             # #
5             # Description: stat() handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::Stat;
14 2     2   464 use strict;
  2         8  
  2         74  
15 2     2   15 use warnings;
  2         6  
  2         198  
16             our $VERSION = "1.5";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 2     2   18 use Fcntl qw(:mode);
  2         6  
  2         636  
24 2     2   19 use No::Worries::Die qw(dief);
  2         7  
  2         19  
25 2     2   21 use No::Worries::Export qw(export_control);
  2         5  
  2         17  
26 2     2   17 use Params::Validate qw(validate :types);
  2         6  
  2         361  
27              
28             #
29             # constants
30             #
31              
32 2     2   18 use constant ST_DEV => 0; # ID of device containing file
  2         6  
  2         170  
33 2     2   16 use constant ST_INO => 1; # inode number
  2         4  
  2         157  
34 2     2   16 use constant ST_MODE => 2; # protection
  2         5  
  2         119  
35 2     2   52 use constant ST_NLINK => 3; # number of hard links
  2         5  
  2         148  
36 2     2   15 use constant ST_UID => 4; # user ID of owner
  2         6  
  2         120  
37 2     2   16 use constant ST_GID => 5; # group ID of owner
  2         10  
  2         138  
38 2     2   16 use constant ST_RDEV => 6; # device ID (if special file)
  2         5  
  2         137  
39 2     2   21 use constant ST_SIZE => 7; # total size, in bytes
  2         19  
  2         123  
40 2     2   16 use constant ST_ATIME => 8; # time of last access
  2         4  
  2         126  
41 2     2   17 use constant ST_MTIME => 9; # time of last modification
  2         4  
  2         114  
42 2     2   14 use constant ST_CTIME => 10; # time of last status change
  2         7  
  2         108  
43 2     2   15 use constant ST_BLKSIZE => 11; # blocksize for filesystem I/O
  2         6  
  2         117  
44 2     2   15 use constant ST_BLOCKS => 12; # number of 512B blocks allocated
  2         6  
  2         124  
45              
46 2     2   15 use constant _IMODE => oct(7777); # all mode bits
  2         11  
  2         109  
47 2     2   14 use constant _IBITS => 12; # number of mode bits
  2         5  
  2         4922  
48              
49             #
50             # global variables
51             #
52              
53             our(
54             @_Mode2Type, # mode (shifted) to file type
55             %_CachedUid, # cached uid from getpwnam()
56             %_CachedGid, # cached gid from getgrnam()
57             );
58              
59             #
60             # check user option and set uid and message accordingly
61             #
62              
63             sub _check_user ($$) {
64 4     4   7 my($option, $message) = @_;
65 4         4 my($user);
66              
67 4         8 $user = $option->{user};
68 4 50       11 return unless defined($user);
69 0 0       0 if ($user =~ /^\d+$/) {
70 0         0 $option->{uid} = $user;
71             } else {
72 0 0       0 unless (exists($_CachedUid{$user})) {
73 0         0 $_CachedUid{$user} = getpwnam($user);
74             dief("unknown user: %s", $user)
75 0 0       0 unless defined($_CachedUid{$user});
76             }
77 0         0 $option->{uid} = $_CachedUid{$user};
78             }
79 0         0 $message->{user} = "user($user)";
80             }
81              
82             #
83             # check group option and set gid and message accordingly
84             #
85              
86             sub _check_group ($$) {
87 4     4   7 my($option, $message) = @_;
88 4         4 my($group);
89              
90 4         5 $group = $option->{group};
91 4 50       8 return unless defined($group);
92 0 0       0 if ($group =~ /^\d+$/) {
93 0         0 $option->{gid} = $group;
94             } else {
95 0 0       0 unless (exists($_CachedGid{$group})) {
96 0         0 $_CachedGid{$group} = getgrnam($group);
97             dief("unknown group: %s", $group)
98 0 0       0 unless defined($_CachedGid{$group});
99             }
100 0         0 $option->{gid} = $_CachedGid{$group};
101             }
102 0         0 $message->{group} = "group($group)";
103             }
104              
105             #
106             # check the mode option and set mode_set, mode_clear and message accordingly
107             #
108              
109             sub _check_mode ($$) {
110 4     4   7 my($option, $message) = @_;
111 4         6 my($mode, $action, $number);
112              
113 4         5 $mode = $option->{mode};
114 4 50       8 return unless defined($mode);
115 4 50       15 if ($mode =~ /^([\+\-])?(\d+)$/) {
116 4   100     14 $action = $1 || "";
117 4 100       16 $number = substr($2, 0, 1) eq "0" ? oct($2) : ($2+0);
118             # use the canonical form for the message
119 4         14 $mode = sprintf("%s%05o", $action, $number);
120 4 100       11 if ($action eq "+") {
    100          
121             # check that at least these bits are set
122 1         2 $option->{mode_set} = $number;
123 1         2 $option->{mode_clear} = 0;
124             } elsif ($action eq "-") {
125             # check that at least these bits are cleared
126 1         2 $option->{mode_set} = 0;
127 1         2 $option->{mode_clear} = $number;
128             } else {
129             # check that these bits are exactly the ones set
130 2         5 $option->{mode_set} = $number;
131 2         3 $option->{mode_clear} = _IMODE;
132             }
133             } else {
134 0         0 dief("invalid mode: %s", $mode);
135             }
136 4         10 $message->{mode} = "mode($mode)";
137             }
138              
139             #
140             # check the mtime option and set message accordingly
141             #
142              
143             sub _check_mtime ($$) {
144 4     4   6 my($option, $message) = @_;
145 4         5 my($mtime);
146              
147 4         4 $mtime = $option->{mtime};
148 4 50       13 return unless defined($mtime);
149 0         0 $message->{mtime} = "mtime($mtime)";
150             }
151              
152             #
153             # ensure proper ownership
154             #
155              
156             sub _ensure_owner ($$$$) {
157 0     0   0 my($path, $stat, $option, $message) = @_;
158 0         0 my(@todo);
159              
160 0         0 @todo = ();
161 0 0 0     0 if ($message->{user} and $stat->[ST_UID] != $option->{uid}) {
162 0         0 $stat->[ST_UID] = $option->{uid};
163 0         0 push(@todo, $message->{user});
164             }
165 0 0 0     0 if ($message->{group} and $stat->[ST_GID] != $option->{gid}) {
166 0         0 $stat->[ST_GID] = $option->{gid};
167 0         0 push(@todo, $message->{group});
168             }
169 0 0 0     0 return(0) unless @todo and $option->{callback}->($path, "@todo");
170 0 0       0 chown($stat->[ST_UID], $stat->[ST_GID], $path)
171             or dief("cannot chown(%d, %d, %s): %s",
172             $stat->[ST_UID], $stat->[ST_GID], $path, $!);
173 0         0 return(1)
174             }
175              
176             #
177             # ensure proper permissions
178             #
179              
180             sub _ensure_mode ($$$$) {
181 4     4   8 my($path, $stat, $option, $message) = @_;
182 4         6 my($mode);
183              
184 4         5 $mode = $stat->[ST_MODE] & _IMODE;
185 4         7 $mode &= ~$option->{mode_clear};
186 4         6 $mode |= $option->{mode_set};
187 4 100       8 return(0) if ($stat->[ST_MODE] & _IMODE) == $mode;
188 3 50       7 return(0) unless $option->{callback}->($path, $message->{mode});
189 3 50       32 chmod($mode, $path)
190             or dief("cannot chmod(%05o, %s): %s", $mode, $path, $!);
191 3         8 return(1)
192             }
193              
194             #
195             # ensure proper modification time
196             #
197              
198             sub _ensure_mtime ($$$$) {
199 0     0   0 my($path, $stat, $option, $message) = @_;
200              
201 0 0       0 return(0) if $stat->[ST_MTIME] == $option->{mtime};
202 0 0       0 return(0) unless $option->{callback}->($path, $message->{mtime});
203             utime($stat->[ST_ATIME], $option->{mtime}, $path)
204             or dief("cannot utime(%d, %d, %s): %s",
205 0 0       0 $stat->[ST_ATIME], $option->{mtime}, $path, $!);
206 0         0 return(1);
207             }
208              
209             #
210             # make sure the the file status is what is expected
211             #
212              
213             my %stat_ensure_options = (
214             user => { optional => 1, type => SCALAR, regex => qr/^[\w\-]+$/ },
215             group => { optional => 1, type => SCALAR, regex => qr/^[\w\-]+$/ },
216             mode => { optional => 1, type => SCALAR, regex => qr/^[\+\-]?\d+$/ },
217             mtime => { optional => 1, type => SCALAR, regex => qr/^\d+$/ },
218             follow => { optional => 1, type => BOOLEAN },
219             callback => { optional => 1, type => CODEREF },
220             );
221              
222             sub stat_ensure ($@) {
223 4     4 1 10 my($path, %option, %message, @stat, $changed);
224              
225 4         7 $path = shift(@_);
226 4 50       66 %option = validate(@_, \%stat_ensure_options) if @_;
227 4         79 _check_user(\%option, \%message);
228 4         10 _check_group(\%option, \%message);
229 4         8 _check_mode(\%option, \%message);
230 4         12 _check_mtime(\%option, \%message);
231 4   50 3   25 $option{callback} ||= sub { return(1) };
  3         6  
232 4 50       10 dief("no options given") unless keys(%message);
233 4 50       8 if ($option{follow}) {
234 0         0 @stat = stat($path);
235 0 0       0 dief("cannot stat(%s): %s", $path, $!) unless @stat;
236             } else {
237 4         44 @stat = lstat($path);
238 4 50       8 dief("cannot lstat(%s): %s", $path, $!) unless @stat;
239             # we do not try to change symbolic links
240 4 50       10 return(undef) if -l _;
241             }
242 4         6 $changed = 0;
243             # first ensure owner
244             $changed += _ensure_owner($path, \@stat, \%option, \%message)
245 4 50 33     14 if $message{user} or $message{group};
246             # then ensure mode
247             $changed += _ensure_mode($path, \@stat, \%option, \%message)
248 4 50       13 if $message{mode};
249             # finally ensure mtime
250             $changed += _ensure_mtime($path, \@stat, \%option, \%message)
251 4 50       11 if $message{mtime};
252 4         27 return($changed);
253             }
254              
255             #
256             # return the file type as a string from stat[ST_MODE]
257             #
258              
259             sub stat_type ($) {
260 9     9 1 5333 my($mode) = @_;
261              
262 9 100       26 unless (@_Mode2Type) {
263 1         2 eval { $_Mode2Type[S_IFREG() >> _IBITS] = "plain file" };
  1         3  
264 1         1 eval { $_Mode2Type[S_IFDIR() >> _IBITS] = "directory" };
  1         2  
265 1         2 eval { $_Mode2Type[S_IFIFO() >> _IBITS] = "pipe" };
  1         2  
266 1         2 eval { $_Mode2Type[S_IFSOCK() >> _IBITS] = "socket" };
  1         2  
267 1         2 eval { $_Mode2Type[S_IFBLK() >> _IBITS] = "block device" };
  1         1  
268 1         2 eval { $_Mode2Type[S_IFCHR() >> _IBITS] = "character device" };
  1         2  
269 1         1 eval { $_Mode2Type[S_IFLNK() >> _IBITS] = "symlink" };
  1         2  
270 1         1 eval { $_Mode2Type[S_IFDOOR() >> _IBITS] = "door" };
  1         14  
271 1         2 eval { $_Mode2Type[S_IFPORT() >> _IBITS] = "event port" };
  1         6  
272 1         2 eval { $_Mode2Type[S_IFNWK() >> _IBITS] = "network file" };
  1         5  
273 1         2 eval { $_Mode2Type[S_IFWHT() >> _IBITS] = "whiteout" };
  1         13  
274             }
275 9         23 $mode &= S_IFMT;
276 9         13 $mode >>= _IBITS;
277 9   50     43 return($_Mode2Type[$mode] || "unknown");
278             }
279              
280             #
281             # export control
282             #
283              
284             sub import : method {
285 2     2   18 my($pkg, %exported);
286              
287 2         6 $pkg = shift(@_);
288 2         201 grep($exported{$_}++, grep(/^ST?_[A-Z]+$/, keys(%No::Worries::Stat::)));
289 2         22 grep($exported{$_}++, qw(stat_ensure stat_type));
290 2         17 export_control(scalar(caller()), $pkg, \%exported, @_);
291             }
292              
293             1;
294              
295             __DATA__