view release on metacpan or  search on metacpan

lib/Chj/xperlfunc.pm  view on Meta::CPAN

package Chj::xperlfunc::xstat {

    # (Alternative to arrays: hashes, so that slices like
    # ->{"dev","ino"} could be done? But so what.)
    sub dev     { shift->[0] }
    sub ino     { shift->[1] }
    sub mode    { shift->[2] }
    sub nlink   { shift->[3] }
    sub uid     { shift->[4] }
    sub gid     { shift->[5] }
    sub rdev    { shift->[6] }
    sub size    { shift->[7] }
    sub atime   { shift->[8] }
    sub mtime   { shift->[9] }
    sub ctime   { shift->[10] }
    sub blksize { shift->[11] }
    sub blocks  { shift->[12] }

    sub set_dev     { my $s = shift; ($s->[0])  = @_; }
    sub set_ino     { my $s = shift; ($s->[1])  = @_; }
    sub set_mode    { my $s = shift; ($s->[2])  = @_; }
    sub set_nlink   { my $s = shift; ($s->[3])  = @_; }
    sub set_uid     { my $s = shift; ($s->[4])  = @_; }
    sub set_gid     { my $s = shift; ($s->[5])  = @_; }
    sub set_rdev    { my $s = shift; ($s->[6])  = @_; }
    sub set_size    { my $s = shift; ($s->[7])  = @_; }
    sub set_atime   { my $s = shift; ($s->[8])  = @_; }
    sub set_mtime   { my $s = shift; ($s->[9])  = @_; }
    sub set_ctime   { my $s = shift; ($s->[10]) = @_; }
    sub set_blksize { my $s = shift; ($s->[11]) = @_; }
    sub set_blocks  { my $s = shift; ($s->[12]) = @_; }

    # test helpers:
    sub permissions     { shift->[2] & 07777 }
    sub permissions_oct { sprintf('%o', shift->permissions) }
    sub permissions_u   { (shift->[2] & 00700) >> 6 }
    sub permissions_g   { (shift->[2] & 00070) >> 3 }
    sub permissions_o   { shift->[2] & 00007 }
    sub permissions_s   { (shift->[2] & 07000) >> 9 }
    sub setuid          { !!(shift->[2] & 04000) }

    # ^ I have no desire to put is_ in front.
    sub setgid { !!(shift->[2] & 02000) }

    # sticky is simply the lowest of the 3 permissions_s bits:
    sub sticky   { !!(shift->[2] & 01000) }
    sub filetype { (shift->[2] & 0170000) >> 12 }    # 4*3bits

    sub fstype {
        my $s = shift;
        Chj::xperlfunc::fstype_for_device($s->dev)
    }

    our $has_no_subdirs_safe_fstype = +{
        ext2     => 1,
        ext3     => 1,
        ext4     => 1,
        tmpfs    => 1,
        vfat     => 1,
        squashfs => 1,
        overlay  => 0,
    };

    sub has_no_subdirs {
        my $s = shift;
        $s->is_dir or die "has_no_subdirs can only be used on directories";
        my $dev    = $s->dev;
        my $fstype = $s->fstype;
        if ($$has_no_subdirs_safe_fstype{$fstype}) {
            my $n = $s->nlink;
            $n < 2
                ? die
                "bug: dir on device node $dev has < 2 links, need to ignore this file system"
                : $n == 2;
        } else {
            undef
        }
    }

    # Guess access rights from permission bits
    # note that these might guess wrong (because of chattr stuff,
    # or things like grsecurity,lids,selinux..)!
    # Also NOTE: this does not check parent folders of this item!
    sub checkaccess_for_submask_by_uid_gids {
        my $s = shift;
        my ($mod, $uid, $gids) = @_;    # the latter being an array ref!
            #return 1 if $uid == 0;
            #  ^ this is not correct for say, is_executable with uid 0;
            #    XXX how should it behave in other cases?
        if ($s->[4] == $uid) {
            return !!($s->[2] & (00100 * $mod))
        } else {
            if ($gids) {
                for my $gid (@$gids) {
                    length($gid) == length($gid +0)
                        or Carp::croak "invalid gid argument '$gid' - maybe "
                        . " you forgot to split '\$)'?";

                    # XXX: what if one is member of group 0, is this special?
                    if ($s->[5] == $gid) {
                        if ($s->[2] & (00010 * $mod)) {
                            return 1;
                        } else {

                            # even if others are allowed, we are not
                            return 0;
                        }
                    }
                }
                return !!($s->[2] & (00001 * $mod))
            } else {
                Carp::croak "missing gids argument - might just be a ref to "
                    . "an empty array";
            }
        }
    }

    sub readable_by_uid_gids {
        splice @_, 1, 0, 4;
        goto &checkaccess_for_submask_by_uid_gids;
    }