view release on metacpan or  search on metacpan

lib/Chj/IO/Tempfile.pm  view on Meta::CPAN

sub attribute {    # :lvalue does not work because of perl bugs. :-(
    my $self = shift;
    my $key  = shift;
    if (@_) {
        ($metadata{ pack "I", $self }[2]{$key}) = @_
    } else {
        $metadata{ pack "I", $self }[2]{$key}
    }
}

sub _xlinkrename {
    my ($from, $to) = @_;    # to must be file path, not dir.
    my $tobase = $to;
    $tobase =~ s{/?([^/]+)\z}{} or croak "_xlinkrename: missing to parameter";
    my $toname = $1;
    $tobase .= "/" if length $tobase;
    for (1 .. 10) {
        my $tmppath = "$tobase.$toname." . rand(10000);
        if (link $from, $tmppath) {
            if (rename $tmppath, $to) {
                return;
            } else {
                croak "_xlinkrename: rename "
                    . Chj::singlequote($tmppath) . ", "
                    . Chj::singlequote($to) . ": $!";
            }
        } else {
            if ($! == EEXIST) {
                next;
            } else {
                croak "_xlinkrename: link "
                    . Chj::singlequote($from) . ", "
                    . Chj::singlequote($tmppath) . ": $!";
            }
        }
    }
    croak "_xlinkrename: too many attempts to make a link from "
        . Chj::singlequote($from)
        . " to a random name around "
        . Chj::singlequote($to) . ": $!";
}

our $warn_all_failures = 1;

sub xreplace_or_withmode {
    my $self = shift;
    my ($targetpath, $orwithmode) = @_;

    # $orwithmode can be an integer, an octal string, or a stat
    # object; in case of a stat object and if running as root, it also
    # keeps uid/gid.
    my $path = $self->xpath;
    my ($uid, $gid, $mode);
    if (($uid, $gid, $mode) = (stat $targetpath)[4, 5, 2]) {
        my $euid = (stat $path)[4];    # better than $> because of peculiarities
        defined $euid
            or croak "xreplace_or_withmode: ?? can't stat own file "
            . Chj::singlequote($path) . ": $!";
        if ($euid == 0) {
            $! = undef;
            chown $uid, $gid, $path
                or croak "xreplace_or_withmode: chown "
                . Chj::singlequote($path) . ": $!";
        } else {
            if ($uid != $euid) {
                carp "xreplace_or_withmode: warning: cannot set owner of "
                    . Chj::singlequote($path)
                    . " to $uid since we are not root"
                    if $warn_all_failures;
                $mode &= 0777;    # see below
            }
            $! = undef;
            chown $euid, $gid, $path or do {

                # only a warning, ok?
                carp "xreplace_or_withmode: warning: could not set group of "
                    . Chj::singlequote($path)
                    . " to $gid: $!"
                    if $warn_all_failures;
                $mode &= 0777;    # mask off setuid and such stuff. correct?
            };
        }

        # keep backup:
        # we need it atomic, thus link. but a 'replacing link'.
        eval {
            _xlinkrename $targetpath, "$targetpath~";    # make configurable?
            1
        } || do {
            warn "xreplace_or_withmode: warning: could not make backup file: $@"
                if $warn_all_failures;
        }
    } else {
        if (defined $orwithmode) {
            if (ref $orwithmode) {

                # assuming stat object
                $mode = $orwithmode->permissions;
                if ($> == 0) {
                    $! = undef;
                    chown $orwithmode->uid, $orwithmode->gid, $path
                        or croak "xreplace_or_withmode: chown "
                        . Chj::singlequote($path) . ": $!";
                }
            } else {
                if ($orwithmode =~ /^0/) {
                    $orwithmode = oct $orwithmode;
                    defined($orwithmode)
                        or croak "xreplace_or_withmode: illegal octal "
                        . "withmode value given";

                    # ^ well, never happens when givint numbers not strings
                }
                $mode = $orwithmode
                    ; # & 0777; # mask off dito, since we do not know which uid/gid the programmer meant. which is a bug in itself.   wellll , programmer should know what he's doing then, right?
            }
        } else {
            croak "xreplace_or_withmode: error getting target permissions"
                . " and no default mode given, stat "
                . Chj::singlequote($targetpath) . ": $!";
        }
    }
    $! = undef;
    chmod $mode, $path
        or croak "xreplace_or_withmode: chmod "
        . Chj::singlequote($path) . ": $!";
    $self->xrename($targetpath);
}

sub xputback {    # better name?
    my $self = shift;
    my ($maybe_orwithmode) = @_;
    croak "xputback: file " . $self->quotedname . " is still open"
        if $self->opened;
    my $basepath = $metadata{ pack "I", $self }[0];
    $self->xreplace_or_withmode($basepath, $maybe_orwithmode);
}

sub basepath {
    my $self = shift;
    $metadata{ pack "I", $self }[0]
}

1