view release on metacpan or  search on metacpan

lib/App/Glacier/Directory.pm  view on Meta::CPAN

package App::Glacier::Directory;
use strict;
use warnings;
use parent 'App::Glacier::DB';
use Carp;
use App::Glacier::Timestamp;

our @EXPORT_OK = qw(DIR_UPTODATE DIR_PENDING DIR_OUTDATED);
our %EXPORT_TAGS = ( status => [ qw(DIR_UPTODATE DIR_PENDING DIR_OUTDATED) ] );

use constant DB_INFO_KEY => ';00INFO';

sub new {
    my ($class, $backend, $vault, $glacier, %opts) = @_;
    (my $vault_name = $vault) =~
	s/([^A-Za-z_0-9\.-])/sprintf("%%%02X", ord($1))/gex;
    map { $opts{$_} =~ s/\$(?:vault|\{vault\})/$vault_name/g } keys %opts;
    my $self = $class->SUPER::new($backend,
				  %opts,
		       create => sub { $glacier->describe_vault($vault_name) },
    );
    if ($self) {
	$self->{_vault} = $vault;
	$self->{_glacier} = $glacier;
    }
    return $self;
}

sub vault { shift->{_vault} }
sub glacier { shift->{_glacier} }

# locate(FILE, VERSION)
sub locate {
    my ($self, $file, $version) = @_;
    $version = 1 unless defined $version;
    my $rec = $self->SUPER::retrieve($file);
    return undef unless defined $rec || $version-1 > $#{$rec};
    return wantarray ? ($rec->[$version-1], $version) : $rec->[$version-1];
}

sub info {
    my ($self, $key) = @_;
    my $rec = $self->retrieve(DB_INFO_KEY);
    return undef unless defined($rec);
    return $rec->{$key};
}

sub set_info {
    my ($self, $key, $val) = @_;
    my $rec = $self->retrieve(DB_INFO_KEY) || {};
    $rec->{$key} = $val;
    $self->SUPER::store(DB_INFO_KEY, $rec);
}

sub last_sync_time {
    my ($self) = @_;
    return $self->info('SyncTimeStamp');
}

sub update_sync_time {
    my ($self) = @_;
    $self->set_info('SyncTimeStamp', time);
}

sub foreach {
    my ($self, $code) = @_;
    $self->SUPER::foreach(sub {
	                      my ($k, $v) = @_;
			      &{$code}($k, $v) unless $k eq DB_INFO_KEY;
			  });
}
	    
sub add_version {
    my ($self, $file_name, $val) = @_;
    my $rec = $self->retrieve($file_name);
    my $i;
    if ($rec) {
	my $t = $val->{CreationDate}->epoch;
	for ($i = 0; $i <= $#{$rec}; $i++) {
	    last if $t >= $rec->[$i]{CreationDate}->epoch;
	}
	splice(@{$rec}, $i, 0, $val);
    } else {
	$i = 0;
	$rec = [ $val ];
    }
    $self->SUPER::store($file_name, $rec);
    return $i + 1;
}

sub delete_version {
    my ($self, $file_name, $ver) = @_;
    $ver--;
    my $rec = $self->retrieve($file_name);
    if ($rec && $ver <= $#{$rec}) {
	splice(@{$rec}, $ver, 1);
	if (@{$rec}) {
	    $self->SUPER::store($file_name, $rec);
	} else {
	    $self->delete($file_name);
	}
    } else {
	++$ver;
	croak "can't remove $file_name;$ver: no such version";
    }
}

sub tempname {
    my ($self, $namelen) = @_;
    $namelen = 10 unless defined $namelen; 
    my @alphabet =
	split //,
	      '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
    my @name;

    for (my $i = 0; $i < $namelen; $i++) {
	push @name, rand($#alphabet);
    }
    my @orig = @name;
    my $s;