view release on metacpan or  search on metacpan

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

package App::Glacier::Command;

use strict;
use warnings;
use Carp;
use App::Glacier::Core;
use parent 'App::Glacier::Core';
use File::Basename;
use File::Spec;
use App::Glacier::EclatCreds;
use App::Glacier::Config;
use App::Glacier::Bre;
use App::Glacier::Timestamp;
use App::Glacier::Directory;
use App::Glacier::Roster;

use Digest::SHA qw(sha256_hex);
use File::Path qw(make_path);

use constant MB => 1024*1024;

sub ck_number {
    my ($vref) = @_;
    return "not a number"
        unless $$vref =~ /^\d+/;
    return undef;
}

sub ck_size {
    my ($vref) = @_;
    if ($$vref =~ /^(\d+)\s*([kKmMgG])?$/) {
	my $size = $1;
	if ($2) {
	    my $suf = lc $2;
	    foreach my $m (qw(k m g)) {
		$size *= 1024;
		last if $m eq $suf;
	    }
	}
	$$vref = $size;
    } else {
	return 'invalid size specification';
    }
}

my %parameters = (
    glacier => {
	section => {
	    credentials => 1,
	    access => 1,
	    secret => 1,
	    region => 1,
	}
    },
    transfer => {
	section => {
	    'single-part-size' => { default => 100*MB, check => \&ck_size },
	    'jobs' => { default => 16, check => \&ck_number },
	    'retries' => { default => 10, check => \&ck_number },
	    upload => {
		section => {
		    'single-part-size' => { check => \&ck_size },
		    'jobs' => { check => \&ck_number },
		    'retries' => { check => \&ck_number },
		}
	    }, 
	    download => {
		section => {
		    'single-part-size' => { check => \&ck_size },
		    'jobs' => { check => \&ck_number },
		    'retries' => { check => \&ck_number },
		    'cachedir' => { default => '/var/lib/glacier/cache' }	
		}
	    }
	}
    },
    database => {
	section => {
	    job => {
		section => {
		    backend => { default => 'GDBM' },
		    '*' => '*'
		},
	    },
	    inv => {
		section => {
		    backend => { default => 'GDBM' },
		    '*' => '*'
		}
	    }
	}
    }
);

sub new {
    my $class = shift;
    my $argref = shift;
    local %_ = @_;

    my $config_file = delete $_{config} || $ENV{GLACIER_CONF};
    unless ($config_file) {
	$config_file = -f '/etc/glacier.conf'
	                ? '/etc/glacier.conf' : '/dev/null';
    }
    my $account = delete $_{account};
    my $region = delete $_{region};

    my $debug = delete $_{debug};
    my $dry_run = delete $_{dry_run};
    my $progname = delete $_{progname};
    
    my $self = $class->SUPER::new($argref, %_);

    $self->{_debug} = $debug if $debug;
    $self->{_dry_run} = $dry_run if $dry_run;
    $self->progname($progname) if $progname;
    
    $self->{_config} = new App::Glacier::Config($config_file,
						debug => $self->{_debug},
						parameters => \%parameters);
    exit(EX_CONFIG) unless $self->{_config}->parse();

    App::Glacier::Roster->configtest($self->cfget(qw(database job backend)),
				     $self->config, 'database', 'job')
	or exit(EX_CONFIG);
    App::Glacier::Directory->configtest($self->cfget(qw(database inv backend)),
					$self->config, 'database', 'inv')
	or exit(EX_CONFIG);

    unless ($self->{_config}->isset(qw(glacier access))
	    && $self->{_config}->isset(qw(glacier secret))) {
	if ($self->{_config}->isset(qw(glacier credentials))) {
	    my $creds = new App::Glacier::EclatCreds($self->{_config}->get(qw(glacier credentials)));
	    $account = $self->{_config}->get(qw(glacier access))
		unless defined $account;
	    if ($creds->has_key($account)) {
		$self->{_config}->set(qw(glacier access),
				      $creds->access_key($account));
		$self->{_config}->set(qw(glacier secret),
				      $creds->secret_key($account));
		$region = $creds->region($account) unless defined $region;
	    }
	}
    }

    $self->{_glacier} = new App::Glacier::Bre($self->config->as_hash('glacier'));
    if ($self->{_glacier}->lasterr) {
	$self->abend(EX_CONFIG, $self->{_glacier}->last_error_message);
    }
    return $self;
}

# Produce a semi-flat clone of $orig, blessing it into $class.
# The clone is semi-flat, because it shares the parsed configuration and
# the glacier object with the $orig.
sub clone {
    my ($class, $orig) = @_;
    my $self = $class->SUPER::clone($orig);
    $self->{_config} = $orig->config; 
    $self->{_glacier} = $orig->{_glacier};
    $self->{_jobdb} = $orig->{_jobdb};
    $self
}

sub option {
    my ($self, $opt, $val) = @_;
    if (defined($val)) {
	$self->{_options}{$opt} = $val;
    }
    return $self->{_options}{$opt};
}

sub touchdir {
    my ($self, $dir) = @_;
    unless (-d $dir) {
        make_path($dir, {error=>\my $err});
        if (@$err) {
            for my $diag (@$err) {
                my ($file, $message) = %$diag;
                $file = $dir if ($file eq '');
                $self->error("error creating $file: $message");
            }
            exit(EX_CANTCREAT);
        }
    }
}

sub jobdb {
    my $self = shift;
    unless ($self->{_jobdb}) {
        my $be = $self->cfget(qw(database job backend));
	$self->{_jobdb} = new App::Glacier::Roster(
	    $be,