view release on metacpan or  search on metacpan

lib/Archive/Tar/Wrapper.pm  view on Meta::CPAN

    my ( $self, $rel_path ) = @_;

    my $real_path = File::Spec->catfile( $self->{tardir}, $rel_path );

    if ( -e $real_path ) {
        $logger->debug("$real_path exists") if ( $logger->is_debug );
        return $real_path;
    }
    else {
        $logger->warn("$rel_path not found in tarball") if ( $logger->is_warn );
        return;
    }
}

sub add {
    my ( $self, $rel_path, $path_or_stringref, $opts ) = @_;

    if ($opts) {
        unless ( ( ref($opts) ) and ( ref($opts) eq 'HASH' ) ) {
            LOGDIE "Option parameter given to add() not a hashref.";
        }
    }

    my ( $perm, $uid, $gid, $binmode );
    $perm    = $opts->{perm}    if defined $opts->{perm};
    $uid     = $opts->{uid}     if defined $opts->{uid};
    $gid     = $opts->{gid}     if defined $opts->{gid};
    $binmode = $opts->{binmode} if defined $opts->{binmode};

    my $target     = File::Spec->catfile( $self->{tardir}, $rel_path );
    my $target_dir = dirname($target);

    unless ( -d $target_dir ) {
        if ( ref($path_or_stringref) ) {
            $self->add( dirname($rel_path), dirname($target_dir) );
        }
        else {
            $self->add( dirname($rel_path), dirname($path_or_stringref) );
        }
    }

    if ( ref($path_or_stringref) ) {
        open my $fh, '>', $target or LOGDIE "Can't open $target: $!";
        if ( defined $binmode ) {
            binmode $fh, $binmode;
        }
        print $fh $$path_or_stringref;
        close $fh;
    }
    elsif ( -d $path_or_stringref ) {

        # perms will be fixed further down
        mkpath( $target, 0, oct(755) ) unless -d $target;
    }
    else {
        copy $path_or_stringref, $target
          or LOGDIE "Can't copy $path_or_stringref to $target ($!)";
    }

    if ( defined $uid ) {
        chown $uid, -1, $target
          or LOGDIE "Can't chown $target uid to $uid ($!)";
    }

    if ( defined $gid ) {
        chown -1, $gid, $target
          or LOGDIE "Can't chown $target gid to $gid ($!)";
    }

    if ( defined $perm ) {
        chmod $perm, $target
          or LOGDIE "Can't chmod $target to $perm ($!)";
    }

    if (    not defined $uid
        and not defined $gid
        and not defined $perm
        and not ref($path_or_stringref) )
    {
        perm_cp( $path_or_stringref, $target )
          or LOGDIE "Can't perm_cp $path_or_stringref to $target ($!)";
    }

    return 1;
}

sub perm_cp {
    my ( $source, $target ) = @_;
    perm_set( $target, perm_get($source) );
    return 1;
}

sub perm_get {
    my ($filename) = @_;
    my @stats = ( stat $filename )[ 2, 4, 5 ]
      or LOGDIE "Cannot stat $filename ($!)";
    return \@stats;
}

sub perm_set {
    my ( $filename, $perms ) = @_;
    chown( $perms->[1], $perms->[2], $filename );
    chmod( $perms->[0] & oct(777), $filename )
      or LOGDIE "Cannot chmod $filename ($!)";
    return 1;
}

sub remove {
    my ( $self, $rel_path ) = @_;
    my $target = File::Spec->catfile( $self->{tardir}, $rel_path );
    rmtree($target) or LOGDIE "Can't rmtree $target: $!";
    return 1;
}

sub list_all {
    my ($self) = @_;
    my @entries = ();
    $self->list_reset();

    while ( my $entry = $self->list_next() ) {
        push @entries, $entry;
    }

    return \@entries;
}

sub list_next {
    my ($self)    = @_;
    my $offset    = $self->_offset();
    my $list_file = File::Spec->catfile( $self->{objdir}, 'list' );
    open my $fh, '<', $list_file or LOGDIE "Can't open $list_file: $!";
    seek $fh, $offset, 0;
    my $data;

  REDO: {
        my $line = <$fh>;

        unless ( defined($line) ) {
            close($fh);
        }
        else {
            chomp $line;
            my ( $type, $entry ) = split / /, $line, 2;
            redo if ( ( $type eq 'd' ) and ( not $self->{dirs} ) );
            $self->_offset( tell $fh );
            close($fh);
            $data =
              [ $entry, File::Spec->catfile( $self->{tardir}, $entry ), $type ];
        }
    }

    return $data;
}

sub _offset {
    my ( $self, $new_offset ) = @_;
    my $offset_file = File::Spec->catfile( $self->{objdir}, "offset" );

    if ( defined $new_offset ) {
        open my $fh, '>', $offset_file or LOGDIE "Can't open $offset_file: $!";
        print $fh "$new_offset\n";
        close $fh;