view release on metacpan or  search on metacpan

lib/Cache/Repository/Filesys.pm  view on Meta::CPAN

}

# when we add a file to a tag, we may want to store meta-info about it.
# filter all completed requests through here.
sub _add_file
{
    my $self = shift;
    my %opts = @_;

    #$self->{r}{$opts{tag}}{$opts{filename}} = undef;
    $self->set_meta(tag => '_r',
                    meta => { 
                        $opts{tag} => {
                            $opts{filename} => {
                                dir => $self->_dir(%opts),
                            },
                        },
                    },
                   );
}

sub _remove_tag
{
    my $self = shift;
    my %opts = @_;

    my $data = $self->get_meta(tag => '_r');
    delete $data->{$opts{tag}};
    $self->set_meta(tag => '_r',
                    reset => 1,
                    meta => $data);
}

sub _lock_meta
{
    my $self = shift;
    my $mode = shift || 'r';

    my $meta_name = do {
        unless (exists $self->{metaname})
        {
            $self->{metaname} = File::Spec->catfile($self->{path}, 'meta.info');
        }
        $self->{metaname};
    };

    my $fh = IO::File->new($meta_name, $mode);
    if ($fh)
    {
        flock($fh, $mode eq 'r' ? LOCK_SH : LOCK_EX);
    }
    $fh;
}

sub _load_meta
{
    my $self = shift;
    my $fh   = $self->_lock_meta();

    # only load it if it's been changed since the last load.
    my $s = stat($self->{metaname});
    if ($s and
        $s->mtime() >= ($self->{metastamp} || 0) and
        $fh)
    {
        local $/;
        my $data = join '', $fh->getlines();
        $self->{metastamp} = time();
        $fh->close(); # release lock

        $self->{meta} = $self->_thaw($data);
    }
}

sub _save_meta
{
    my $self = shift;
    my $fh   = $self->_lock_meta('w');

    $fh->print($self->_freeze($self->{meta}));
    $fh->close();
}

sub _thaw
{
    my $self = shift;
    my $data = shift;
    eval 'my ' . $data;
}

sub _freeze
{
    my $self = shift;
    my $data = shift;
    require Data::Dumper;
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Purity = 1;
    join '', Data::Dumper::Dumper($data);
}

=item get_meta

Overrides L<Cache::Repository>'s get_meta function

=cut

sub get_meta
{
    my $self = shift;
    my %opts = @_;

    $self->_load_meta();
    unless (exists $self->{meta}{$opts{tag}})
    {
        $self->{meta}{$opts{tag}} = {}
    }
    $self->{meta}{$opts{tag}};
}

=item set_meta

lib/Cache/Repository/Filesys.pm  view on Meta::CPAN

    my %opts = @_;
    my $dir  = $self->_dir($opts{tag});

    return 0 unless $self->_is_filename_ok($opts{filename});

    my $dstfile = File::Spec->catdir($dir, $opts{filename});

    mkpath(dirname($dstfile));
    #my $rc = copy($opts{filehandle}, $dstfile);
    my $rc = 0;
    {
        local $/ = \32768;
        local $_;

        if (open my $dst_h, '>', $dstfile)
        {
            binmode $dst_h;
            my $in_h = $opts{filehandle};
            print $dst_h $_ while <$in_h>;
            $rc = 1;
        }
    }

    chmod $opts{mode}, $dstfile if exists $opts{mode};
    chown $opts{owner}, $opts{group}, $dstfile
        if exists $opts{owner} and exists $opts{group};
    if ($rc)
    {
        $self->_add_file(%opts);
    }
    $rc;
}

=item retrieve_with_callback

=cut

sub retrieve_with_callback
{
    my $self = shift;
    my %opts = @_;

    my $callback = $opts{callback};
    my @files_to_extract;

    my $repos_dir = $self->_dir($opts{tag});
    return undef unless -d $repos_dir;

    if (exists $opts{files})
    {
        @files_to_extract = ref $opts{files} ? @{$opts{files}} : ($opts{files});
    }
    else
    {
        @files_to_extract = $self->list_files(%opts);
    }

    foreach my $file (@files_to_extract)
    {
        my $srcname = File::Spec->catfile($repos_dir, $file);
        my $s = stat($srcname);

        return 0 unless $s;

        my %cb_opts = (
                       mode => $s->mode(),
                       owner => $s->uid(),
                       group => $s->gid(),
                       filename => $file,
                       start => 1,
                      );
        if (-l $srcname)
        {
            $callback->(%cb_opts, target => readlink($srcname)) or return 0;
        }
        else
        {
            my $fh = IO::File->new($srcname, 'r') or return 0;
            binmode $fh;

            my $buf;
            while (my $r = sysread($fh, $buf, 32 * 1024))
            {
                $callback->(%cb_opts, data => $buf) or return 0;
                delete $cb_opts{start};
            }
            $buf = undef;
            $callback->(%cb_opts, data => undef, end => 1) or return 0;
        }
    }
    return 1;
}

=item get_size

=cut

sub get_size
{
    my $self = shift;
    my %opts = @_;

    my $repos_dir = $self->_dir($opts{tag});
    return 0 unless -d $repos_dir;

    my @files;

    if (exists $opts{files})
    {
        @files = ref $opts{files} ? @{$opts{files}} : ($opts{files});
    }
    else
    {
        @files = $self->list_files(%opts);
    }

    my $size;
    my $dir = $self->_dir($opts{tag});
    foreach my $f (@files)
    {
        my $s;