FunctionalPerl

 view release on metacpan or  search on metacpan

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

    xsystem
    xxsystem
    xsystem_safe
    xxsystem_safe
    xrename
    xmkdir
    xrmdir
    xchmod
    xchown
    xchdir
    xstat
    xlstat
    Xstat
    Xlstat
    xlocaltime
    xreadlink
    xunlink
    xlink
    xsymlink
    xutime
    xkill
    xeval
    xwaitpid
    xxwaitpid
    xwait
    xxwait
    xsysread
    xchroot
);
our @EXPORT_OK = qw(
    xspawn
    xlaunch
    xmvmkdir
    xmkdir_with_paragon
    xtmpdir_with_paragon
    xlinkunlink
    xlinkreplace
    xxcarefulrename
    xfileno
    basename
    dirname
    xmkdir_p
    xlink_p
    xgetpwnam
    xgetgrnam
    caching_getpwnam
    caching_getgrnam
    xprint
    xprintln
    xLmtimed
    XLmtimed
    xLmtime
    XLmtime
    min max
    fstype_for_device
    xgetfile_utf8 xslurp
    maybe_getfile_utf8
);

# would we really want to export these?:
#caching_getpwuid
#caching_getgrgid
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

use Carp;
use FP::Carp;
use Chj::singlequote 'singlequote_many';    # the only dependency so far
use Chj::Unix::Exitcode qw(exitcode);

BEGIN {
    if ($^O eq 'linux') {
        eval 'sub EEXIST() {17} sub ENOENT() {2}';
        die if $@;
    } else {
        eval 'use POSIX "EEXIST","ENOENT"';
        die if $@;
    }
}

sub xfork {
    @_ == 0 or fp_croak_arity 0;
    my $pid = fork;
    defined $pid or croak "xfork: $!";
    $pid
}

# thread-like API; incomplete, for sure.
sub xfork_(&) {
    @_ == 1 or fp_croak_arity 1;
    my ($thunk) = @_;
    my $pid = xfork;
    if ($pid) {
        $pid
    } else {

        # kinda run in a new dynamic context, please... (evil,
        # e.g. $SIG{__WARN__} is still set; do all of this?)
        eval {
            &$thunk();

            # drop return value (transfer via pipe? 'No.')
            exit 0;    # POSIX::_exit ? no? Anyway docs say otherwise.
        } || do {
            warn "uncaught exception in subprocess $$, exiting: $@";
            exit 1;    # POSIX::_exit ? no?
        }
    }
}

sub xexec {
    no warnings;
    exec @_;
    croak "xexec " . singlequote_many(@_) . ": $!";
}

sub xexec_safe {
    no warnings;
    exec { $_[0] } @_;
    croak "xexec_safe " . singlequote_many(@_) . ": $!";
}

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

            return;
        } else {
            croak(@_ ? "Xstat: '@_': $!" : "Xstat: '$_': $!");
        }
    };
    my $wantarray = wantarray;    ## no critic
    if ($wantarray) {
        cluck "Xstat call in array context doesn't make sense";
        @r
    } elsif (defined $wantarray) {
        bless \@r, 'Chj::xperlfunc::xstat'
    } else {
        cluck "Xstat call in void context doesn't make sense";
    }
}

# XX ditto
sub Xlstat {
    @_ <= 2 or croak "Xlstat: too many arguments";
    my ($path, $accept_errors) = @_;
    $path = $_ unless @_;
    my @r = lstat_possiblyhires($path);
    @r or do {
        if ($accept_errors or $! == ENOENT) {
            return;
        } else {
            croak("Xlstat: '$path': $!");
        }
    };
    my $wantarray = wantarray;    ## no critic
    if ($wantarray) {
        cluck "Xlstat call in array context doesn't make sense";
        @r
    } elsif (defined $wantarray) {
        bless \@r, 'Chj::xperlfunc::xstat'
    } else {
        cluck "Xlstat call in void context doesn't make sense";
    }
}

# caching variants of perlfuncs:

sub mk_caching_getANYid {
    my ($function, $scalarindex, $methodname) = @_;
    my %cache;
    sub {
        @_ == 1 or fp_croak_arity 1;
        my ($id) = @_;
        if (defined $id) {
            my $v;
            if (not defined($v = $cache{$id})) {
                $v = [&$function($id)];
                $cache{$id} = $v;
            }
            wantarray ? @$v : $$v[$scalarindex]    ## no critic
        } else {
            croak "$methodname: got undefined value";
        }
    }
}
*caching_getpwuid
    = mk_caching_getANYid(sub { getpwuid $_[0] }, 0, "caching_getpwuid");
*caching_getgrgid
    = mk_caching_getANYid(sub { getgrgid $_[0] }, 0, "caching_getgrgid");

*caching_getpwnam
    = mk_caching_getANYid(sub { getpwnam $_[0] }, 2, "caching_getpwnam");
*caching_getgrnam
    = mk_caching_getANYid(sub { getgrnam $_[0] }, 2, "caching_getgrnam");

our $fstype_for_device;

sub fstype_for_device_init {
    @_ == 0 or fp_croak_arity 0;
    open my $mounts, "<", "/proc/mounts" or die "/proc/mounts: $!";
    local $/ = "\n";
    my %t;
    local $_;
    while (<$mounts>) {    ## no critic, $_ is localized
        my @f = split / /, $_;
        my ($_dev, $mountpoint, $fstype) = @f;
        if (
            (
                $fstype eq "rootfs"

                # stupid Linux, not only source but also fs type is shown
                # as rootfs.
            )
            or (
                $fstype eq "autofs"

                # more stupid: entry with systemd-1 source, then later
                # with binfmt_misc source and fstype
            )
            )
        {
            # Ignore and count on the second entry from /proc/mounts
            # for the same mount.
        } else {
            if (defined(my $s = Xlstat($mountpoint, 1))) {
                my $dev = $s->dev;
                if (defined $t{$dev}) {
                    $t{$dev} eq $fstype
                        or die
                        "entry for '$dev' was previously set to '$t{$dev}', now '$fstype'";
                }
                $t{ $s->dev } = $fstype;
            }
        }

        # else silently ignore, presumably the fs should be reachable
        # at another location then, or the $dev in question would
        # never be found by that user. OK?
    }
    close $mounts or die $!;
    $fstype_for_device = \%t;
}

sub fstype_for_device {
    @_ == 1 or fp_croak_arity 1;
    my ($dev) = @_;
    my $t = $fstype_for_device->{$dev};

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

                and $s->executable_by_uid_gids($uid, $gids))
    }

    sub type {
        my $s = shift;
        if    ($s->is_dir)         {"dir"}
        elsif ($s->is_link)        {"link"}
        elsif ($s->is_file)        {"file"}
        elsif ($s->is_socket)      {"socket"}
        elsif ($s->is_chardevice)  {"chardevice"}
        elsif ($s->is_blockdevice) {"blockdevice"}
        elsif ($s->is_pipe)        {"pipe"}
        else { die "unknown type of filetype: " . $s->filetype }
    }

    # check whether "a file has changed"
    sub equal_content {
        my $s = shift;
        my ($s2) = @_;
        (           $s->dev == $s2->dev
                and $s->ino == $s2->ino
                and $s->size == $s2->size
                and $s->mtime == $s2->mtime)
    }

    # Could also implement FP::Abstract::Equal, but do not just use
    # the following *equal for it, rather check *all* the fields!
    sub equal {
        my $s = shift;
        my ($s2) = @_;

        # permissions:
        (           $s->equal_content($s2)
                and $s->mode == $s2->mode
                and $s->uid == $s2->uid
                and $s->gid == $s2->gid)
    }

    sub same_node {
        my $s = shift;
        my ($s2) = @_;
        ($s->ino == $s2->ino and $s->dev == $s2->dev)
    }

# for simplicity (and in cases where I copy values in 'rows' (lists of methods)):
# ATTENTION: these are non-caching! see below.
    sub username {
        my $s = shift;
        scalar $s->getpw
    }

    sub groupname {
        my $s = shift;
        scalar $s->getgr
    }

    # note that those are sensitive to list context!:
    # (and yes those should 'probably' return such objects as these, too..)
    sub getpw {
        my $s = shift;
        getpwuid($s->uid)
    }

    sub getgr {
        my $s = shift;
        getgrgid($s->gid)
    }

    # for performance:
    sub caching_getpw {
        my $s = shift;
        Chj::xperlfunc::caching_getpwuid($s->uid);
    }

    sub caching_getgr {
        my $s = shift;
        Chj::xperlfunc::caching_getgrgid($s->gid);
    }

    sub caching_username {
        my $s = shift;
        scalar $s->caching_getpw
    }

    sub caching_groupname {
        my $s = shift;
        scalar $s->caching_getgr
    }
}

use FP::Div qw(min max);    # min just for the backwards-compatible
                            # re-export

package Chj::xperlfunc::mtimed {

    sub path       { shift->[0] }
    sub mtime      { shift->[1] }
    sub lstat      { shift->[2] }
    sub maybe_stat { shift->[3] }

    # ---
    sub xstat {
        my $s = shift;
        $$s[3] || die "Xstat gave file not found for: '$$s[0]'";
    }

    sub is_link {
        shift->[2]->is_link
    }

    sub is_dir {
        my $s = shift;
        $s->is_link ? $s->xstat->is_dir : $s->lstat->is_dir
    }

    sub is_file {
        my $s = shift;
        $s->is_link ? $s->xstat->is_file : $s->lstat->is_file
    }
}

sub XLmtimed {
    @_ == 1 or fp_croak_arity 1;
    my ($path) = @_;
    if (my $ls = Xlstat $path) {
        bless do {
            if ($ls->is_link) {
                if (my $s = Xstat $path) {
                    [$path, max($ls->mtime, $s->mtime), $ls, $s]
                } else {
                    [$path, $ls->mtime, $ls, undef]
                }