1#+##############################################################################
2#                                                                              #
3# File: No/Worries/Stat.pm                                                     #
4#                                                                              #
5# Description: stat() handling without worries                                 #
6#                                                                              #
7#-##############################################################################
8
9#
10# module definition
11#
12
13package No::Worries::Stat;
14use strict;
15use warnings;
16our $VERSION  = "1.6";
17our $REVISION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);
18
19#
20# used modules
21#
22
23use Fcntl qw(:mode);
24use No::Worries::Die qw(dief);
25use No::Worries::Export qw(export_control);
26use Params::Validate qw(validate :types);
27
28#
29# constants
30#
31
32use constant ST_DEV     =>  0;     # ID of device containing file
33use constant ST_INO     =>  1;     # inode number
34use constant ST_MODE    =>  2;     # protection
35use constant ST_NLINK   =>  3;     # number of hard links
36use constant ST_UID     =>  4;     # user ID of owner
37use constant ST_GID     =>  5;     # group ID of owner
38use constant ST_RDEV    =>  6;     # device ID (if special file)
39use constant ST_SIZE    =>  7;     # total size, in bytes
40use constant ST_ATIME   =>  8;     # time of last access
41use constant ST_MTIME   =>  9;     # time of last modification
42use constant ST_CTIME   => 10;     # time of last status change
43use constant ST_BLKSIZE => 11;     # blocksize for filesystem I/O
44use constant ST_BLOCKS  => 12;     # number of 512B blocks allocated
45
46use constant _IMODE => oct(7777);  # all mode bits
47use constant _IBITS => 12;         # number of mode bits
48
49#
50# global variables
51#
52
53our(
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
63sub _check_user ($$) {
64    my($option, $message) = @_;
65    my($user);
66
67    $user = $option->{user};
68    return unless defined($user);
69    if ($user =~ /^\d+$/) {
70        $option->{uid} = $user;
71    } else {
72        unless (exists($_CachedUid{$user})) {
73            $_CachedUid{$user} = getpwnam($user);
74            dief("unknown user: %s", $user)
75                unless defined($_CachedUid{$user});
76        }
77        $option->{uid} = $_CachedUid{$user};
78    }
79    $message->{user} = "user($user)";
80}
81
82#
83# check group option and set gid and message accordingly
84#
85
86sub _check_group ($$) {
87    my($option, $message) = @_;
88    my($group);
89
90    $group = $option->{group};
91    return unless defined($group);
92    if ($group =~ /^\d+$/) {
93        $option->{gid} = $group;
94    } else {
95        unless (exists($_CachedGid{$group})) {
96            $_CachedGid{$group} = getgrnam($group);
97            dief("unknown group: %s", $group)
98                unless defined($_CachedGid{$group});
99        }
100        $option->{gid} = $_CachedGid{$group};
101    }
102    $message->{group} = "group($group)";
103}
104
105#
106# check the mode option and set mode_set, mode_clear and message accordingly
107#
108
109sub _check_mode ($$) {
110    my($option, $message) = @_;
111    my($mode, $action, $number);
112
113    $mode = $option->{mode};
114    return unless defined($mode);
115    if ($mode =~ /^([\+\-])?(\d+)$/) {
116        $action = $1 || "";
117        $number = substr($2, 0, 1) eq "0" ? oct($2) : ($2+0);
118        # use the canonical form for the message
119        $mode = sprintf("%s%05o", $action, $number);
120        if ($action eq "+") {
121            # check that at least these bits are set
122            $option->{mode_set} = $number;
123            $option->{mode_clear} = 0;
124        } elsif ($action eq "-") {
125            # check that at least these bits are cleared
126            $option->{mode_set} = 0;
127            $option->{mode_clear} = $number;
128        } else {
129            # check that these bits are exactly the ones set
130            $option->{mode_set} = $number;
131            $option->{mode_clear} = _IMODE;
132        }
133    } else {
134        dief("invalid mode: %s", $mode);
135    }
136    $message->{mode} = "mode($mode)";
137}
138
139#
140# check the mtime option and set message accordingly
141#
142
143sub _check_mtime ($$) {
144    my($option, $message) = @_;
145    my($mtime);
146
147    $mtime = $option->{mtime};
148    return unless defined($mtime);
149    $message->{mtime} = "mtime($mtime)";
150}
151
152#
153# ensure proper ownership
154#
155
156sub _ensure_owner ($$$$) {
157    my($path, $stat, $option, $message) = @_;
158    my(@todo);
159
160    @todo = ();
161    if ($message->{user} and $stat->[ST_UID] != $option->{uid}) {
162        $stat->[ST_UID] = $option->{uid};
163        push(@todo, $message->{user});
164    }
165    if ($message->{group} and $stat->[ST_GID] != $option->{gid}) {
166        $stat->[ST_GID] = $option->{gid};
167        push(@todo, $message->{group});
168    }
169    return(0) unless @todo and $option->{callback}->($path, "@todo");
170    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    return(1)
174}
175
176#
177# ensure proper permissions
178#
179
180sub _ensure_mode ($$$$) {
181    my($path, $stat, $option, $message) = @_;
182    my($mode);
183
184    $mode = $stat->[ST_MODE] & _IMODE;
185    $mode &= ~$option->{mode_clear};
186    $mode |=  $option->{mode_set};
187    return(0) if ($stat->[ST_MODE] & _IMODE) == $mode;
188    return(0) unless $option->{callback}->($path, $message->{mode});
189    chmod($mode, $path)
190        or dief("cannot chmod(%05o, %s): %s", $mode, $path, $!);
191    return(1)
192}
193
194#
195# ensure proper modification time
196#
197
198sub _ensure_mtime ($$$$) {
199    my($path, $stat, $option, $message) = @_;
200
201    return(0) if $stat->[ST_MTIME] == $option->{mtime};
202    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                $stat->[ST_ATIME], $option->{mtime}, $path, $!);
206    return(1);
207}
208
209#
210# make sure the the file status is what is expected
211#
212
213my %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
222sub stat_ensure ($@) {
223    my($path, %option, %message, @stat, $changed);
224
225    $path = shift(@_);
226    %option = validate(@_, \%stat_ensure_options) if @_;
227    _check_user(\%option, \%message);
228    _check_group(\%option, \%message);
229    _check_mode(\%option, \%message);
230    _check_mtime(\%option, \%message);
231    $option{callback} ||= sub { return(1) };
232    dief("no options given") unless keys(%message);
233    if ($option{follow}) {
234        @stat = stat($path);
235        dief("cannot stat(%s): %s", $path, $!) unless @stat;
236    } else {
237        @stat = lstat($path);
238        dief("cannot lstat(%s): %s", $path, $!) unless @stat;
239        # we do not try to change symbolic links
240        return(undef) if -l _;
241    }
242    $changed = 0;
243    # first ensure owner
244    $changed += _ensure_owner($path, \@stat, \%option, \%message)
245        if $message{user} or $message{group};
246    # then ensure mode
247    $changed += _ensure_mode($path, \@stat, \%option, \%message)
248        if $message{mode};
249    # finally ensure mtime
250    $changed += _ensure_mtime($path, \@stat, \%option, \%message)
251        if $message{mtime};
252    return($changed);
253}
254
255#
256# return the file type as a string from stat[ST_MODE]
257#
258
259sub stat_type ($) {
260    my($mode) = @_;
261
262    unless (@_Mode2Type) {
263        eval { $_Mode2Type[S_IFREG()  >> _IBITS] = "plain file" };
264        eval { $_Mode2Type[S_IFDIR()  >> _IBITS] = "directory" };
265        eval { $_Mode2Type[S_IFIFO()  >> _IBITS] = "pipe" };
266        eval { $_Mode2Type[S_IFSOCK() >> _IBITS] = "socket" };
267        eval { $_Mode2Type[S_IFBLK()  >> _IBITS] = "block device" };
268        eval { $_Mode2Type[S_IFCHR()  >> _IBITS] = "character device" };
269        eval { $_Mode2Type[S_IFLNK()  >> _IBITS] = "symlink" };
270        eval { $_Mode2Type[S_IFDOOR() >> _IBITS] = "door" };
271        eval { $_Mode2Type[S_IFPORT() >> _IBITS] = "event port" };
272        eval { $_Mode2Type[S_IFNWK()  >> _IBITS] = "network file" };
273        eval { $_Mode2Type[S_IFWHT()  >> _IBITS] = "whiteout" };
274    }
275    $mode &= S_IFMT;
276    $mode >>= _IBITS;
277    return($_Mode2Type[$mode] || "unknown");
278}
279
280#
281# export control
282#
283
284sub import : method {
285    my($pkg, %exported);
286
287    $pkg = shift(@_);
288    grep($exported{$_}++, grep(/^ST?_[A-Z]+$/, keys(%No::Worries::Stat::)));
289    grep($exported{$_}++, qw(stat_ensure stat_type));
290    export_control(scalar(caller()), $pkg, \%exported, @_);
291}
292
2931;
294
295__DATA__
296
297=head1 NAME
298
299No::Worries::Stat - stat() handling without worries
300
301=head1 SYNOPSIS
302
303  use No::Worries::Stat qw(*);
304
305  @stat = stat($path) or die;
306  printf("type is %s\n", stat_type($stat[ST_MODE]));
307  printf("size is %d\n", $stat[ST_SIZE]);
308  printf("user can read\n") if $stat[ST_MODE] & S_IRUSR;
309
310  # make sure "/bin/ls" is owned by root and has the right permissions
311  stat_ensure("/bin/ls", user => "root", mode => 0755);
312  # make sure "/var/log" is not group or world writable
313  stat_ensure("/var/log", mode => "-022");
314  # idem but using the S_* constants
315  stat_ensure("/var/log", mode => "-" . (S_IWGRP|S_IWOTH));
316
317=head1 DESCRIPTION
318
319This module eases file status handling by providing convenient constants and
320functions to get, set and manipulate file status information. All the
321functions die() on error.
322
323=head1 CONSTANTS
324
325This module provides the following constants to ease access to stat() fields
326(none of them being exported by default):
327
328=over
329
330=item C<ST_DEV>
331
332ID of device containing file
333
334=item C<ST_INO>
335
336inode number
337
338=item C<ST_MODE>
339
340protection
341
342=item C<ST_NLINK>
343
344number of hard links
345
346=item C<ST_UID>
347
348user ID of owner
349
350=item C<ST_GID>
351
352group ID of owner
353
354=item C<ST_RDEV>
355
356device ID (if special file)
357
358=item C<ST_SIZE>
359
360total size, in bytes
361
362=item C<ST_ATIME>
363
364time of last access
365
366=item C<ST_MTIME>
367
368time of last modification
369
370=item C<ST_CTIME>
371
372time of last status change
373
374=item C<ST_BLKSIZE>
375
376blocksize for filesystem I/O
377
378=item C<ST_BLOCKS>
379
380number of 512B blocks allocated
381
382=back
383
384In addition, it also optionally exports all the ":mode" constants from L<Fcntl>.
385
386This way, all the stat() related constants can be imported in a uniform way.
387
388=head1 FUNCTIONS
389
390This module provides the following functions (none of them being
391exported by default):
392
393=over
394
395=item stat_type(MODE)
396
397given the file mode (C<ST_MODE> field), return the file type as a string;
398possible return values are: "block device", "character device", "directory",
399"door", "event port", "network file", "pipe", "plain file", "socket",
400"symlink", "unknown" and "whiteout".
401
402=item stat_ensure(PATH[, OPTIONS])
403
404make sure the given path has the expected file "status" (w.r.t. stat()) and
405call chown(), chmod() or utime() if needed, returning the number of changes
406performed; supported options:
407
408=over
409
410=item * C<user>: expected user name or uid
411
412=item * C<group>: expected group name or gid
413
414=item * C<mode>: expected mode specification (see below)
415
416=item * C<mtime>: expected modification time
417
418=item * C<follow>: follow symbolic links (default is to skip them)
419
420=item * C<callback>: code to be executed before changing something (see below)
421
422=back
423
424=back
425
426The C<mode> option of stat_ensure() can be given:
427
428=over
429
430=item I<NUMBER>
431
432an absolute value like 0755, meaning that mode must be equal to it
433
434=item +I<NUMBER>
435
436a list of bits that must be set, e.g. "+0111" for "executable for all"
437
438=item -I<NUMBER>
439
440a list of bits that must be clear, e.g. "-022" for not writable by group or
441other
442
443=back
444
445Note: the number after "+" or "-" will be interpreted as being octal only if
446it starts with "0". You should therefore use "+0111" or "+".oct(111) to
447enable the executable bits but not "+111" which is the same as "+0157".
448
449The C<callback> option of stat_ensure() will receive the given path and a
450string describing what is about to be changed. It must return true to tell
451stat_ensure() to indeed perform the changes.
452
453Here is for insatnce how a "noaction" option could be implemented:
454
455  sub noaction ($$) {
456      my($path, $change) = @_;
457
458      printf("did not change %s of %s\n", $change, $path);
459      return(0);
460  }
461  foreach my $path (@paths) {
462      stat_ensure($path, user => "root", mode => 0755, callback => \&noaction);
463  }
464
465=head1 SEE ALSO
466
467L<Fcntl>,
468L<No::Worries>.
469
470=head1 AUTHOR
471
472Lionel Cons L<http://cern.ch/lionel.cons>
473
474Copyright (C) CERN 2012-2019
475