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

#+##############################################################################
#                                                                              #
# File: No/Worries/Stat.pm                                                     #
#                                                                              #
# Description: stat() handling without worries                                 #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::Stat;
use strict;
use warnings;
our $VERSION  = "1.5";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Fcntl qw(:mode);
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use Params::Validate qw(validate :types);

#
# constants
#

use constant ST_DEV     =>  0;     # ID of device containing file
use constant ST_INO     =>  1;     # inode number
use constant ST_MODE    =>  2;     # protection
use constant ST_NLINK   =>  3;     # number of hard links
use constant ST_UID     =>  4;     # user ID of owner
use constant ST_GID     =>  5;     # group ID of owner
use constant ST_RDEV    =>  6;     # device ID (if special file)
use constant ST_SIZE    =>  7;     # total size, in bytes
use constant ST_ATIME   =>  8;     # time of last access
use constant ST_MTIME   =>  9;     # time of last modification
use constant ST_CTIME   => 10;     # time of last status change
use constant ST_BLKSIZE => 11;     # blocksize for filesystem I/O
use constant ST_BLOCKS  => 12;     # number of 512B blocks allocated

use constant _IMODE => oct(7777);  # all mode bits
use constant _IBITS => 12;         # number of mode bits

#
# global variables
#

our(
    @_Mode2Type,  # mode (shifted) to file type
    %_CachedUid,  # cached uid from getpwnam()
    %_CachedGid,  # cached gid from getgrnam()
);

#
# check user option and set uid and message accordingly
#

sub _check_user ($$) {
    my($option, $message) = @_;
    my($user);

    $user = $option->{user};
    return unless defined($user);
    if ($user =~ /^\d+$/) {
        $option->{uid} = $user;
    } else {
        unless (exists($_CachedUid{$user})) {
            $_CachedUid{$user} = getpwnam($user);
            dief("unknown user: %s", $user)
                unless defined($_CachedUid{$user});
        }
        $option->{uid} = $_CachedUid{$user};
    }
    $message->{user} = "user($user)";
}

#
# check group option and set gid and message accordingly
#

sub _check_group ($$) {
    my($option, $message) = @_;
    my($group);

    $group = $option->{group};
    return unless defined($group);
    if ($group =~ /^\d+$/) {
        $option->{gid} = $group;
    } else {
        unless (exists($_CachedGid{$group})) {
            $_CachedGid{$group} = getgrnam($group);
            dief("unknown group: %s", $group)
                unless defined($_CachedGid{$group});
        }
        $option->{gid} = $_CachedGid{$group};
    }
    $message->{group} = "group($group)";
}

#
# check the mode option and set mode_set, mode_clear and message accordingly
#

sub _check_mode ($$) {
    my($option, $message) = @_;
    my($mode, $action, $number);

    $mode = $option->{mode};
    return unless defined($mode);
    if ($mode =~ /^([\+\-])?(\d+)$/) {
        $action = $1 || "";
        $number = substr($2, 0, 1) eq "0" ? oct($2) : ($2+0);
        # use the canonical form for the message
        $mode = sprintf("%s%05o", $action, $number);
        if ($action eq "+") {
            # check that at least these bits are set
            $option->{mode_set} = $number;
            $option->{mode_clear} = 0;
        } elsif ($action eq "-") {
            # check that at least these bits are cleared
            $option->{mode_set} = 0;
            $option->{mode_clear} = $number;
        } else {
            # check that these bits are exactly the ones set
            $option->{mode_set} = $number;
            $option->{mode_clear} = _IMODE;
        }
    } else {
        dief("invalid mode: %s", $mode);
    }
    $message->{mode} = "mode($mode)";
}

#
# check the mtime option and set message accordingly
#

sub _check_mtime ($$) {
    my($option, $message) = @_;
    my($mtime);

    $mtime = $option->{mtime};
    return unless defined($mtime);
    $message->{mtime} = "mtime($mtime)";
}

#
# ensure proper ownership
#

sub _ensure_owner ($$$$) {
    my($path, $stat, $option, $message) = @_;
    my(@todo);

    @todo = ();
    if ($message->{user} and $stat->[ST_UID] != $option->{uid}) {
        $stat->[ST_UID] = $option->{uid};
        push(@todo, $message->{user});
    }
    if ($message->{group} and $stat->[ST_GID] != $option->{gid}) {
        $stat->[ST_GID] = $option->{gid};
        push(@todo, $message->{group});
    }
    return(0) unless @todo and $option->{callback}->($path, "@todo");
    chown($stat->[ST_UID], $stat->[ST_GID], $path)
        or dief("cannot chown(%d, %d, %s): %s",
                $stat->[ST_UID], $stat->[ST_GID], $path, $!);
    return(1)
}

#
# ensure proper permissions
#

sub _ensure_mode ($$$$) {
    my($path, $stat, $option, $message) = @_;
    my($mode);

    $mode = $stat->[ST_MODE] & _IMODE;
    $mode &= ~$option->{mode_clear};
    $mode |=  $option->{mode_set};
    return(0) if ($stat->[ST_MODE] & _IMODE) == $mode;
    return(0) unless $option->{callback}->($path, $message->{mode});
    chmod($mode, $path)
        or dief("cannot chmod(%05o, %s): %s", $mode, $path, $!);
    return(1)
}

#
# ensure proper modification time
#

sub _ensure_mtime ($$$$) {
    my($path, $stat, $option, $message) = @_;

    return(0) if $stat->[ST_MTIME] == $option->{mtime};
    return(0) unless $option->{callback}->($path, $message->{mtime});
    utime($stat->[ST_ATIME], $option->{mtime}, $path)
        or dief("cannot utime(%d, %d, %s): %s",
                $stat->[ST_ATIME], $option->{mtime}, $path, $!);
    return(1);
}

#
# make sure the the file status is what is expected
#

my %stat_ensure_options = (
    user     => { optional => 1, type => SCALAR, regex => qr/^[\w\-]+$/ },
    group    => { optional => 1, type => SCALAR, regex => qr/^[\w\-]+$/ },
    mode     => { optional => 1, type => SCALAR, regex => qr/^[\+\-]?\d+$/ },
    mtime    => { optional => 1, type => SCALAR, regex => qr/^\d+$/ },
    follow   => { optional => 1, type => BOOLEAN },
    callback => { optional => 1, type => CODEREF },
);

sub stat_ensure ($@) {
    my($path, %option, %message, @stat, $changed);

    $path = shift(@_);
    %option = validate(@_, \%stat_ensure_options) if @_;
    _check_user(\%option, \%message);
    _check_group(\%option, \%message);
    _check_mode(\%option, \%message);
    _check_mtime(\%option, \%message);
    $option{callback} ||= sub { return(1) };
    dief("no options given") unless keys(%message);
    if ($option{follow}) {
        @stat = stat($path);
        dief("cannot stat(%s): %s", $path, $!) unless @stat;
    } else {
        @stat = lstat($path);
        dief("cannot lstat(%s): %s", $path, $!) unless @stat;
        # we do not try to change symbolic links
        return(undef) if -l _;
    }
    $changed = 0;
    # first ensure owner
    $changed += _ensure_owner($path, \@stat, \%option, \%message)
        if $message{user} or $message{group};
    # then ensure mode
    $changed += _ensure_mode($path, \@stat, \%option, \%message)
        if $message{mode};
    # finally ensure mtime
    $changed += _ensure_mtime($path, \@stat, \%option, \%message)
        if $message{mtime};
    return($changed);
}

#
# return the file type as a string from stat[ST_MODE]
#

sub stat_type ($) {
    my($mode) = @_;

    unless (@_Mode2Type) {
        eval { $_Mode2Type[S_IFREG()  >> _IBITS] = "plain file" };
        eval { $_Mode2Type[S_IFDIR()  >> _IBITS] = "directory" };
        eval { $_Mode2Type[S_IFIFO()  >> _IBITS] = "pipe" };
        eval { $_Mode2Type[S_IFSOCK() >> _IBITS] = "socket" };
        eval { $_Mode2Type[S_IFBLK()  >> _IBITS] = "block device" };
        eval { $_Mode2Type[S_IFCHR()  >> _IBITS] = "character device" };
        eval { $_Mode2Type[S_IFLNK()  >> _IBITS] = "symlink" };
        eval { $_Mode2Type[S_IFDOOR() >> _IBITS] = "door" };
        eval { $_Mode2Type[S_IFPORT() >> _IBITS] = "event port" };
        eval { $_Mode2Type[S_IFNWK()  >> _IBITS] = "network file" };
        eval { $_Mode2Type[S_IFWHT()  >> _IBITS] = "whiteout" };
    }
    $mode &= S_IFMT;
    $mode >>= _IBITS;
    return($_Mode2Type[$mode] || "unknown");
}

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++, grep(/^ST?_[A-Z]+$/, keys(%No::Worries::Stat::)));
    grep($exported{$_}++, qw(stat_ensure stat_type));
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__