FunctionalPerl

 view release on metacpan or  search on metacpan

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

a previous target. All the same it does the replace atomically.
(It works by creating a link to a temporary location then rename.)
(Hm, strange function name?)

=item xfileno $string_or_FH

Does work with both filehandles and integer strings. Croaks if it's
neither or there's an error.

=item basename $pathstring [,$suffix(es) [,$insensitive]]

Same as the shell util of the same name, except that it croaks in a
few cases (when an empty string is given, or when the given suffix
doesn't match).

=item dirname $pathstring

Same as the shell util (or about as my old FolderOfThisFile function),
except that it croaks if dirname of "/" or "." is requested.

=item xmkdir_p $pathstring

Works like unix's "mkdir -p": return false if the directory already
exists, true if it (and, if necessary, it's parent(s)) has(/have) been
created, croaks if some error happens on the way.

=item xlink_p $frompath, $topath

xlink's $frompath to $topath but 

=back

=head1 NOTE

This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.

=cut

#'

package Chj::xperlfunc;
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Exporter "import";

our @EXPORT = qw(
    xfork
    xfork_
    xexec
    xexec_safe
    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);

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

        };
    } else {
        if (lstat $dest) {

            # (yes, link too already fails if target exists as a
            # dangling symlink)
            croak "xxcarefulrename: target '$dest' already exists";
        } else {
            rename $source, $dest
                or croak "xxcarefulrename(" . join(", ", @_) . "): $!";
        }
    }
}

sub xlinkreplace {
    @_ == 2 or fp_croak_arity 2;
    my ($source, $dest) = @_;
    ## schon wieder dieser temporary try mechanismus. sollte ich dringend eine generische func oder ein makro dafür haben theoretisch
# nun im gegensatz zu Tempfile.pm brauchen wir kein eval hier. Aber auch das waer ja per func/macro machbar
    my $path;
TRY: {
        for (1 .. 3) {
            $! = 0;
            my $rand = int(rand(99999) * 100000 + rand(99999));

            # well, not good enough for dangerous cases nor reasonable for
            # non-dangerous cases?
            $path = "$source.tmp$rand~";
            last TRY if link $source, $path;
        }
        croak "xlinkreplace: failed 3 attempts to create hardlinks from "
            . "'$source' to e.g. '$path': $!";
    }
    rename $path, $dest
        or croak "xlinkreplace: could not rename '$path' to '$dest': $!";
}

sub xmkdir {
    if (@_ == 1) {
        mkdir $_[0] or croak "xmkdir($_[0]): $!";
    } elsif (@_ == 2) {
        mkdir $_[0], $_[1] or croak "xmkdir(" . join(", ", @_) . "): $!";
    } else {
        croak "xmkdir: wrong number of arguments";
    }
}

sub xrmdir {
    if (@_ == 1) {
        rmdir $_[0] or croak "xrmdir($_[0]): $!";
    } else {
        croak "xrmdir: wrong number of arguments";
    }
}

sub xchmod {
    @_ >= 1 or croak "xchmod: not enoug arguments";    # should it be >1?
    chmod shift, @_ or croak "xchmod: $!";
}

sub xchown {
    @_ >= 2 or croak "xchown: not enoug arguments";    # should it be >2?
    chown shift, shift, @_ or croak "xchown: $!";
}

sub xchdir {
    chdir $_[0] or croak "xchdir '$_[0]': $!";
}

our $time_hires = 0;

sub stat_possiblyhires {
    if ($time_hires) {
        require Time::HiRes;    # (that's not slow, right?)
        if (@_) {
            @_ == 1 or fp_croak_arity 1;
            Time::HiRes::stat($_[0])
        } else {
            Time::HiRes::stat($_)
        }
    } else {
        if (@_) {
            @_ == 1 or fp_croak_arity 1;
            stat($_[0])
        } else {
            stat($_)
        }
    }
}

sub lstat_possiblyhires {
    if ($time_hires) {
        require Chj::Linux::HiRes;
        if (@_) {
            @_ == 1 or fp_croak_arity 1;
            Chj::Linux::HiRes::lstat($_[0])
        } else {
            Chj::Linux::HiRes::lstat($_)
        }
    } else {
        if (@_) {
            @_ == 1 or fp_croak_arity 1;
            lstat($_[0])
        } else {
            lstat($_)
        }
    }
}

# XX: should provide a newly named function to give the object,
# instead of using wantarray. Have xstat behave like the Perl builtin
# (and then possibly drop and replace by another solution from
# core/CPAN).
sub xstat {
    my @r;
    @_ <= 1 or croak "xstat: too many arguments";
    @r = stat_possiblyhires(@_ ? @_ : $_);
    @r or croak(@_ ? "xstat: '@_': $!" : "xstat: '$_': $!");
    my $wantarray = wantarray;    ## no critic
    if ($wantarray) {
        @r
    } elsif (defined $wantarray) {
        my $self = \@r;

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

    sub set_yday  { my ($s, $v) = @_; $s->[7] = $v;        $s }    # 0..36[45]
    sub set_isdst { my ($s, $v) = @_; $s->[8] = $v;        $s }
    sub set_Year  { my ($s, $v) = @_; $s->[5] = $v - 1900; $s }
    sub set_Mon   { my ($s, $v) = @_; $s->[4] = $v - 1;    $s }

    #sub set_Wday
    #sub set_wDay
    # but those don't have any effect on timelocal anyway.

    sub unixtime {
        my $s = shift;
        Time::Local::timelocal(@$s)
    }

    sub iso_week_number {
        my $s = shift;

        # On which yday does week 01 start for `Year`?

        my $wDay = $s->wDay;
        my $yday = $s->yday;

        my $weekstart_day = $yday - $wDay;

        my ($offset, $weeks) = ($weekstart_day % 7, int($weekstart_day / 7));

        my $week = ($offset >= 4) ? $weeks + 2 : $weeks + 1;
        $yday < $offset ? "LASTYEAR" : $week

            # XX needs to give the year, actually! Buggy.
    }

    sub Year_and_iso_week_number {
        my $s = shift;
        $s->Year . "-W" . $s->iso_week_number

            # XX needs to give the year with the week, actually! Buggy.
    }
}

sub xlocaltime {
    @_ >= 0 and @_ <= 1 or fp_croak_arity "0-1";
    bless [localtime(defined $_[0] ? $_[0] : time)],
        "Chj::xperlfunc::xlocaltime"
}

sub xreadlink {
    my $res
        = @_ == 0 ? readlink
        : @_ == 1 ? readlink $_[0]
        :           croak "xreadlink: wrong number of arguments";
    defined $res or croak @_ ? "xreadlink @_: $!" : "xreadlink: $!";
    $res
}

sub xmkdir_with_paragon {
    @_ == 2 or @_ == 3 or fp_croak_arity "2 or 3";
    warn "UNTESTED!";
    my ($owner, $group, $mode) = (xstat $_[1])[4, 5, 2];
    xmkdir $_[0], 0;
    if (!chown $owner, $group, $_[0]) {
        $_[2] and croak "xmvmkdir: could not recreate user or group: $!";
    }
    xchmod $mode, $_[0];
}

package Chj::xperlfunc::tmpdir {

    sub DESTROY {
        my $self = shift;
        local ($@, $!);
        rmdir $$self                              ## hack
            and warn "removed tmpdir '$$self'";   ## should it warn? prolly not.
    }
}

sub xtmpdir_with_paragon {
    @_ == 1 or @_ == 2 or fp_croak_arity "1 or 2";
    my ($paragon, $strict) = @_;
    my ($owner, $group, $mode) = (xstat $paragon)[4, 5, 2];
    my $newname;
TRY: for (0 .. 2) {
        $newname = $paragon;
        $newname =~ s{(^|/)([^/]+)\z}{"$1.$2.tmp".int(rand(100000))}se;
        last TRY if mkdir $newname, 0;
        if ($! != EEXIST) {
            croak "xtmpdir_with_paragon: mkdir: $!";
        }
    }
    if (!chown $owner, $group, $newname) {
        if ($strict) {
            rmdir $newname;
            croak "xtmpdir_with_paragon: could not recreate user or group: $!";
        }
    }
    if (!chmod $mode, $newname) {
        rmdir $newname;
        croak "xtmpdir_with_paragon: chmod: $!";
    }
    return bless \$newname, 'Chj::xperlfunc::tmpdir';

    # ^ so that it will be removed upon error
}

sub xmvmkdir {
    @_ == 2 or @_ == 3 or fp_croak_arity "2 or 3";
    xrename $_[0], $_[1];
    my ($owner, $group, $mode) = (xstat $_[1])[4, 5, 2];
    xmkdir $_[0], 0;
    if (!chown $owner, $group, $_[0]) {
        $_[2] and croak "xmvmkdir: could not recreate user or group: $!";
    }
    xchmod $mode, $_[0];
}

sub xunlink {
    for (@_) {
        unlink $_ or croak "xunlink '$_': $!";
    }
}

sub xlink {
    @_ == 2 or fp_croak_arity 2;
    link $_[0], $_[1] or croak "xlink '$_[0]','$_[1]': $!";
}

sub xsymlink {
    @_ == 2 or fp_croak_arity 2;
    symlink $_[0], $_[1] or croak "xsymlink to '$_[1]': $!";
}

sub xutime {
    @_ >= 2 or fp_croak_arity ">= 2";
    my ($atime, $mtime) = (shift, shift);
    utime $atime, $mtime, @_ or croak "xutime @_: $!";
}

sub xkill {
    my $sig = shift;
    kill $sig, @_ or croak "xkill $sig @_: $!";
}

sub xchroot {
    @_ == 1 or fp_croak_arity 1;
    my ($rtd) = @_;
    chroot $rtd or die "could not chroot to '$rtd': $!";
}

sub xeval {    # meant for string eval only, of course.
    @_ == 1 or die "wrong number of arguments";
    ## hm ps should one localize $@ here?
    my $wantarray = wantarray;    ## no critic
    if (defined $wantarray) {
        if ($wantarray) {
            my @res = eval $_[0];
            if (ref $@ or $@) {
                die $@
            } else {
                @res
            }
        } else {
            my $res = eval $_[0];
            if (ref $@ or $@) {
                die $@
            } else {
                $res
            }
        }
    } else {
        eval $_[0];