App-MtAws
view release on metacpan or search on metacpan
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
our @EXPORT = qw/option options positional command validation message
mandatory optional seen deprecated validate scope
present valid value lists raw_option custom error warning impose explicit/;
our $context; # it's a not a global. always localized in code
# TODOS
#refactor messages %option a% vs %option option%
#options_encoding_error specify source of problem
sub message($;$%)
{
my ($message, $format, %opts) = @_;
$format = $message unless defined $format;
confess "message $message already defined" if defined $context->{messages}->{$message} and !$context->{messages}->{$message}->{allow_redefine};
$context->{messages}->{$message} = { %opts, format => $format };
$message;
}
sub new
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
if (ref($_) eq ref({})) {
my $name = $_->{format} || confess "format not defined";
confess qq{message $name not defined} unless $self->{messages}->{$name} and my $format = $self->{messages}->{$name}->{format};
error_to_message($format, %$_);
} else {
$_;
}
} @{$err};
}
sub arrayref_or_undef($)
{
my ($ref) = @_;
defined($ref) && @$ref > 0 ? $ref : undef;
}
sub define($&)
{
my ($self, $block) = @_;
local $context = $self; # TODO: create wrapper like 'localize sub ..'
$block->();
}
sub decode_option_value
{
my ($self, $val) = @_;
my $enc = $self->{cmd_encoding}||confess;
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
$dest->{$k} = $v->{value};
}
}
$self->{data} = $options;
}
sub assert_option { $context->{options}->{$_} or confess "undeclared option $_"; }
sub option($;%) {
my ($name, %opts) = @_;
confess "option already declared" if $context->{options}->{$name};
if (%opts) {
if (defined $opts{alias}) {
$opts{alias} = [$opts{alias}] if ref $opts{alias} eq ref ''; # TODO: common code for two subs, move out
}
if (defined $opts{deprecated}) {
$opts{deprecated} = [$opts{deprecated}] if ref $opts{deprecated} eq ref '';
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
confess "alias $_ already declared" if defined $context->{optaliasmap}->{$_};
$context->{optaliasmap}->{$_} = $name;
}
$context->{deprecated_options}->{$_} = 1 for (@{$opts{deprecated}||[]});
}
$context->{options}->{$name} = { %opts, name => $name } unless $context->{options}->{$name};
return $name;
};
sub positional($;%)
{
option shift, @_, positional => 1;
}
sub options(@) {
map {
confess "option already declared $_" if $context->{options}->{$_};
$context->{options}->{$_} = { name => $_ };
$_
} @_;
};
sub validation(@)
{
my ($name, $message, $cb, %opts) = (shift, shift, pop @_, @_);
confess "undeclared option" unless defined $context->{options}->{$name};
push @{ $context->{options}->{$name}->{validations} }, { %opts, 'message' => $message, cb => $cb }
unless $context->{override_validations} && exists($context->{override_validations}->{$name});
$name;
}
sub command($@)
{
my ($name, $cb, %opts) = (shift, pop, @_); # firs arg is name, last is cb, optional middle is opt
confess "command $name already declared" if defined $context->{commands}->{$name};
confess "alias $name already declared" if defined $context->{aliasmap}->{$name};
if (%opts) {
$opts{alias} = [$opts{alias}] if (defined $opts{alias}) && (ref $opts{alias} eq ref '');
$opts{deprecated} = [$opts{deprecated}] if (defined $opts{deprecated}) && ref $opts{deprecated} eq ref '';
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
confess "alias $_ already declared" if defined $context->{aliasmap}->{$_};
$context->{aliasmap}->{$_} = $name;
}
$context->{deprecated_commands}->{$_} = 1 for (@{$opts{deprecated}||[]});
}
$context->{commands}->{$name} = { cb => $cb, %opts };
return;
};
sub _real_option_name($)
{
my ($opt) = @_;
defined($opt->{original_option}) ? $opt->{original_option} : $opt->{name};
}
sub seen
{
my $o = @_ ? shift : $_;
my $option = $context->{options}->{$o} or confess "undeclared option $o";
unless ($option->{seen}) {
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
@{$option}{qw/value source/} = (decode($context->{cmd_encoding}||'UTF-8', $v, Encode::DIE_ON_ERR|Encode::LEAVE_SRC), 'positional');
}) {
error("options_encoding_error", encoding => $context->{cmd_encoding}||'UTF-8'); # TODO: actually remove UTF and fix tests
}
}
}
}
$o;
}
sub mandatory(@) {
return map {
my $opt = assert_option;
unless ($opt->{seen}) {
seen;
confess "mandatory positional argument goes after optional one"
if ($opt->{positional} and ($context->{positional_level} ||= 'mandatory') ne 'mandatory');
unless (defined($opt->{value})) {
$opt->{positional} ?
error("positional_mandatory", a => $_, n => scalar @{$context->{positional_backlog}||[]}+1) :
error("mandatory", a => _real_option_name($opt)); # actually does not have much sense
}
}
$_;
} @_;
};
sub optional(@)
{
return map {
seen;
$context->{positional_level} = 'optional' if ($context->{options}->{$_}->{positional});
$_;
} @_;
};
sub deprecated(@)
{
return map {
assert_option;
my $opt = $context->{options}->{ seen() };
confess "positional options can't be deprecated" if $opt->{positional};
if (defined $opt->{value}) {
warning('option_deprecated_for_command', a => _real_option_name $opt) if $opt->{source} eq 'option';
undef $opt->{value};
}
$_;
} @_;
};
sub validate(@)
{
return map {
my $opt = $context->{options}->{seen()};
if (defined($opt->{value}) && !$opt->{validated}) {
$opt->{validated} = $opt->{valid} = 1;
VALIDATION: for my $v (@{ $opt->{validations} }) {
for ($opt->{value}) {
error ({ format => $v->{message}, a => _real_option_name $opt, value => $_}),
$opt->{valid} = 0,
$v->{stop} && last VALIDATION
unless $v->{cb}->();
}
}
};
$_;
} @_;
};
sub scope($@)
{
my $scopename = shift;
return map {
assert_option;
unshift @{$context->{options}->{$_}->{scope}}, $scopename;
$_;
} @_;
};
sub present(@) # TODO: test that it works with arrays
{
my $name = @_ ? shift : $_;
assert_option for $name;
return defined($context->{options}->{$name}->{value})
};
# TODO: test
sub explicit(@) # TODO: test that it works with arrays
{
my $name = @_ ? shift : $_;
return present($name) && $context->{options}->{$name}->{source} eq 'option'
};
sub valid($)
{
my ($name) = @_;
assert_option for $name;
confess "validation not performed yet" unless $context->{options}->{$name}->{validated};
return $context->{options}->{$name}->{valid};
};
sub value($)
{
my ($name) = @_;
assert_option for $name;
confess "option not present" unless defined($context->{options}->{$name}->{value});
return $context->{options}->{$name}->{value};
};
sub impose(@)
{
my ($name, $value) = @_;
assert_option for $name;
my $opt = $context->{options}->{$name};
$opt->{source} = 'impose';
$opt->{value} = $value;
return $name;
};
sub lists(@)
{
my @a = @_;
grep { my $o = $_; first { $_ eq $o->{name} } @a; } @{$context->{option_list}};
}
sub raw_option($)
{
my ($name) = @_;
assert_option for $name;
confess "option not present" unless defined($context->{options}->{$name}->{value});
return $context->{options}->{$name};
};
sub custom($$)
{
my ($name, $value) = @_;
confess if ($context->{options}->{$name});
$context->{options}->{$name} = {source => 'set', value => $value, name => $name, seen => 1 };
return $name;
};
sub error($;%)
{
my ($name, %data) = @_;
push @{$context->{errors}},
defined($context->{messages}->{$name}) ?
{ format => $name, %data } :
(%data ? confess("message '$name' is undefined") : $name);
return;
};
sub warning($;%)
{
my ($name, %data) = @_;
push @{$context->{warnings}},
defined($context->{messages}->{$name}) ?
{ format => $name, %data } :
(%data ? confess("message '$name' is undefined") : $name);
return;
};
sub read_config
lib/App/MtAws/ForkEngine.pm view on Meta::CPAN
use POSIX;
use Exporter 'import';
our @EXPORT_OK = qw/with_forks fork_engine/;
# some DSL
our $FE = undef;
sub fork_engine()
{
$FE||confess;
}
sub with_forks($$&)
{
my ($flag, $options, $cb) = @_;
local $FE = undef;
if ($flag) {
$FE = App::MtAws::ForkEngine->new(options => $options);
$FE->start_children();
if (defined eval {$cb->(); 1;}) {
$FE->terminate_children();
} else {
dump_error(q{parent});
lib/App/MtAws/GlacierRequest.pm view on Meta::CPAN
my $auth = "AWS4-HMAC-SHA256 Credential=$self->{key}/$credentials, SignedHeaders=$signed_headers, Signature=$signature";
push @{$self->{req_headers}}, { name => 'Authorization', value => $auth};
}
sub _max_retries { 100 }
sub _sleep($) { sleep shift }
sub throttle
{
my ($i) = @_;
if ($i <= 5) {
_sleep 1;
} elsif ($i <= 10) {
_sleep 5;
} elsif ($i <= 20) {
_sleep 15;
lib/App/MtAws/HttpSegmentWriter.pm view on Meta::CPAN
use warnings;
use utf8;
use App::MtAws::Utils;
use Fcntl qw/SEEK_SET LOCK_EX/;
use Carp;
use base qw/App::MtAws::HttpWriter/;
# when file not found/etc error happen, it can mean Temp file deleted by another process, so we
# don't need to throw error, most likelly signal will arrive in a few milliseconds
sub delayed_confess(@)
{
sleep 2;
confess @_;
}
sub new
{
my ($class, %args) = @_;
my $self = \%args;
lib/App/MtAws/QueueJobResult.pm view on Meta::CPAN
sub full_new
{
my ($class, %args) = @_;
my $self = $class->new(%args);
$self->{_type} = 'full';
return $self;
}
### Class methods and DSL
sub is_code($)
{
$valid_codes_h{shift()};
}
# state STATE
# returns: list with 2 elements
sub state($)
{
my $class = __PACKAGE__;
confess unless wantarray;
return
$class->partial_new(state => shift),
$class->partial_new(default_code => JOB_RETRY);
}
# job JOB
# returns: list with 2 elements
sub job(@)
{
my ($job, $cb) = @_;
confess unless wantarray;
return
JOB_RETRY,
__PACKAGE__->partial_new(job => { job => $job, $cb ? (cb => $cb) : () } );
}
# task ACTION, sub { ... }
# task ACTION, { k1 => v1, k2 => v2 ... }, sub { ... }
# task ACTION, { k1 => v1, k2 => v2 ... }, \$ATTACHMENT, sub { ... }
# returns: list with 2 elements
sub task(@)
{
confess unless wantarray;
my $class = __PACKAGE__;
confess "at least two args expected" unless @_ >= 2;
my ($task_action, $cb, $task_args, $attachment) = (shift, pop, @_);
if (ref $task_action eq ref {}) {
my $h = $task_action;
($task_action, $task_args, $attachment) = ($h->{action}, $h->{args}, $h->{attachment} ? $h->{attachment} : ());
}
lib/App/MtAws/Utils.pm view on Meta::CPAN
return undef if $abspath eq ''; # workaround RT#47755
# workaround RT#47755 - in case perms problem it tries to return File::Spec->rel2abs
return undef unless -e $abspath && file_inodev($abspath, use_filename_encoding => 0) eq $orig_id;
return $abspath;
}
our $_filename_encoding = 'UTF-8'; # global var
sub set_filename_encoding($) { $_filename_encoding = shift };
sub get_filename_encoding() { $_filename_encoding || confess };
sub binaryfilename(;$)
{
encode(get_filename_encoding, @_ ? shift : $_, Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
}
sub characterfilename(;$)
{
decode(get_filename_encoding, @_ ? shift : $_, Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
}
# TODO: test
sub abs2rel
{
my ($path, $base) = (shift, shift);
confess "too few arguments" unless defined($path) && defined($base);
my (%args) = (use_filename_encoding => 1, @_);
lib/App/MtAws/Utils.pm view on Meta::CPAN
2) File is not a plain file
3) File is not a plain file, but after open (race conditions)
4) File is empty and not_empty specified
5) File is empty and not_empty specified, but after open (race conditions)
NOTE: If you want exceptions for (2) and (4) - check it before open_file. And additional checks inside open_file will
prevent race conditions
=cut
sub open_file($$%)
{
(undef, my $filename, my %args) = @_;
%args = (use_filename_encoding => 1, %args);
my $original_filename = $filename;
my %checkargs = %args;
defined $checkargs{$_} && delete $checkargs{$_} for qw/use_filename_encoding mode file_encoding not_empty binary/;
confess "Unknown argument(s) to open_file: ".join(';', keys %checkargs) if %checkargs;
confess 'Argument "mode" is required' unless defined($args{mode});
lib/App/MtAws/Utils.pm view on Meta::CPAN
my $f = $_[0];
confess unless -f $f; # check for race condition - it was a file when we last checked, but now it's a directory
confess if $args{not_empty} && (! -s $f);
binmode $f if $args{binary};
return $f;
}
sub file_size($%)
{
my $filename = shift;
my (%args) = (use_filename_encoding => 1, @_);
if ($args{use_filename_encoding}) {
$filename = binaryfilename $filename;
}
confess "file not exists" unless -f $filename;
return -s $filename;
}
sub file_exists($%)
{
my $filename = shift;
my (%args) = (use_filename_encoding => 1, @_);
if ($args{use_filename_encoding}) {
$filename = binaryfilename $filename;
}
return -f $filename;
}
sub file_mtime($%)
{
my $filename = shift;
my (%args) = (use_filename_encoding => 1, @_);
if ($args{use_filename_encoding}) {
$filename = binaryfilename $filename;
}
confess "file not exists" unless -f $filename;
return stat($filename)->mtime;
}
# TODO: test
sub file_inodev($%)
{
my $filename = shift;
my (%args) = (use_filename_encoding => 1, @_);
if ($args{use_filename_encoding}) {
$filename = binaryfilename $filename;
}
confess "file not exists" unless -e $filename;
my $s = stat($filename);
$s->dev."-".$s->ino;
}
lib/App/MtAws/Utils.pm view on Meta::CPAN
defined($_[0]) && utf8::is_utf8($_[0]) && (bytes::length($_[0]) != length($_[0]))
}
# if we have ASCII-only data, let's drop UTF-8 flag in order to optimize some regexp stuff
# TODO: write also version which does not check is_utf8 - it's faster when utf8 always set
sub try_drop_utf8_flag
{
Encode::_utf8_off($_[0]) if utf8::is_utf8($_[0]) && (bytes::length($_[0]) == length($_[0]));
}
sub sysreadfull_chk($$$)
{
my $len = $_[2];
sysreadfull(@_) == $len;
}
sub sysreadfull($$$)
{
my ($file, $len) = ($_[0], $_[2]);
my $n = 0;
while ($len - $n) {
my $i = sysread($file, $_[1], $len - $n, $n);
if (defined($i)) {
if ($i == 0) {
return $n;
} else {
$n += $i;
}
} elsif ($!{EINTR}) {
redo;
} else {
return $n ? $n : undef;
}
}
return $n;
}
sub syswritefull_chk($$)
{
my $length = length $_[1];
syswritefull(@_) == $length
}
sub syswritefull($$)
{
my ($file, $len) = ($_[0], length($_[1]));
confess if is_wide_string($_[1]);
my $n = 0;
while ($len - $n) {
my $i = syswrite($file, $_[1], $len - $n, $n);
if (defined($i)) {
$n += $i;
} elsif ($!{EINTR}) {
redo;
lib/App/MtAws/Utils.pm view on Meta::CPAN
$out .= $resp->headers->as_string;
if ($resp->content_type eq 'application/json' && $resp->content && length($resp->content)) {
$out .= "\n".$resp->content;
}
$out .= "\n\n";
$out;
}
sub get_config_var($) # separate function so we can override it in tests
{
$Config{shift()}
}
sub is_64bit_os
{
get_config_var('longsize') >= 8
}
sub is_64bit_time
t/integration/config_engine_filters.t view on Meta::CPAN
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use Test::MockModule;
use Data::Dumper;
sub assert_filters($$@)
{
my ($msg, $queryref, @parsed) = @_;
fake_config sub {
disable_validations qw/journal secret key filename dir/ => sub {
my $res = config_create_and_parse(@$queryref);
#print Dumper $res->{errors};
ok !($res->{errors}||$res->{warnings}), $msg;
is scalar (my @got = @{$res->{options}{filters}{parsed}{filters}}), scalar @parsed;
while (@parsed) {
my $got = shift @got;
my $expected = shift @parsed;
cmp_deeply $got, superhashof $expected;
}
}
}
}
sub assert_fails($$%)
{
my ($msg, $queryref, $novalidations, $error, %opts) = @_;
fake_config sub {
disable_validations qw/journal key secret dir/, @$novalidations => sub {
my $res = config_create_and_parse(@$queryref);
ok $res->{errors}, $msg;
ok !defined $res->{warnings}, $msg;
ok !defined $res->{command}, $msg;
is_deeply $res->{errors}, [{%opts, format => $error}], $msg;
}
t/integration/config_engine_partsize.t view on Meta::CPAN
use strict;
use warnings;
use utf8;
use Test::More tests => 86;
use Test::Deep;
use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use App::MtAws::Utils;
sub assert_partsize($$@) # should have same number of assertions as assert_partsize_error
{
my $msg = shift;;
my $expected = shift;;
my $res = config_create_and_parse(@_);
ok !($res->{errors}||$res->{warnings}), $msg;
is $res->{options}{partsize}, $expected, $msg;
}
sub assert_partsize_error($$@) # should have same number of assertions as assert_partsize
{
my $msg = shift;;
my $error = shift;;
my $res = config_create_and_parse(@_);
ok $res->{errors}, $msg;
cmp_deeply $res->{errors}, $error, $msg;
}
for my $line (
[qw!sync --config glacier.cfg --vault myvault --journal j --dir a --concurrency=1!],
t/integration/config_engine_segment_size.t view on Meta::CPAN
use warnings;
use utf8;
use Test::More tests => 39;
use Test::Deep;
use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
sub assert_segment_size($$@)
{
my $msg = shift;;
my $expected = shift;;
my $res = config_create_and_parse(@_);
ok !($res->{errors}||$res->{warnings}), $msg;
is $res->{options}{file_downloads}{'segment-size'}, $expected, $msg;
}
sub assert_segment_error($$@)
{
my $msg = shift;;
my $error = shift;;
my $res = config_create_and_parse(@_);
cmp_deeply $res->{errors}, $error, $msg;
}
for my $line (
[qw!restore-completed --config glacier.cfg --vault myvault --journal j --dir a!],
) {
t/integration/config_engine_sync_new.t view on Meta::CPAN
use warnings;
use utf8;
use Test::More tests => 173;
use Test::Deep;
use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
# TODO: reenable when get rid of GetOpt warning
sub assert_options($$@)
{
my $msg = shift;;
my $expected = shift;;
my $res = config_create_and_parse(@_);
ok !($res->{errors}||$res->{warnings}), $msg;
cmp_deeply $res->{options}, superhashof($expected), $msg;
}
sub assert_error($$@)
{
my $msg = shift;;
my $error = shift;;
my $res = config_create_and_parse(@_);
cmp_deeply $res->{errors}, $error, $msg;
}
for my $line (
[qw!sync --config glacier.cfg --vault myvault --journal j --dir a!],
) {
t/integration/config_engine_upload_file.t view on Meta::CPAN
config=>'glacier.cfg',
timeout => 180,
'journal-encoding' => 'UTF-8',
'filenames-encoding' => 'UTF-8',
'terminal-encoding' => 'UTF-8',
'config-encoding' => 'UTF-8'
);
#### PASS
sub assert_passes($$%)
{
my ($msg, $query, %result) = @_;
fake_config sub {
disable_validations qw/journal secret key filename dir/ => sub {
my $res = config_create_and_parse(split(' ', $query));
print Dumper $res->{errors} if $res->{errors};
ok !($res->{errors}||$res->{warnings}), $msg;
is $res->{command}, 'upload-file', $msg;
is_deeply($res->{options}, {
%common,
t/integration/config_engine_upload_file.t view on Meta::CPAN
'data-type' => 'stdin',
stdin => 1,
'check-max-file-size' => 100,
relfilename => 'x/y/z',
'set-rel-filename' => 'x/y/z';
#### FAIL
sub assert_fails($$%)
{
my ($msg, $query, $novalidations, $error, %opts) = @_;
fake_config sub {
disable_validations qw/journal key secret/, @$novalidations => sub {
my $res = config_create_and_parse(split(' ', $query));
ok $res->{errors}, $msg;
ok !defined $res->{warnings}, $msg;
ok !defined $res->{command}, $msg;
cmp_deeply [grep { $_->{format} eq $error } @{ $res->{errors} }], [{%opts, format => $error}], $msg;
}
t/integration/config_engine_upload_file_real.t view on Meta::CPAN
'journal-encoding' => 'UTF-8',
'terminal-encoding' => 'UTF-8',
'config-encoding' => 'UTF-8'
);
#
# some integration testing
#
sub assert_passes_on_filesystem($$%)
{
my ($msg, $query, %result) = @_;
fake_config sub {
disable_validations qw/journal secret key/ => sub {
my $res = config_create_and_parse(@$query);
print Dumper $res->{error_texts} if $res->{errors};
ok !($res->{errors}||$res->{warnings}), $msg;
is $res->{command}, 'upload-file', $msg;
is_deeply($res->{options}, {
%common,
%result
}, $msg);
}
}
}
sub assert_fails_on_filesystem($$%)
{
my ($msg, $query, $novalidations, $error, %opts) = @_;
fake_config sub {
disable_validations qw/journal key secret/, @$novalidations => sub {
my $res = config_create_and_parse(@$query);
print Dumper $res->{options} unless $res->{errors};
ok $res->{errors}, $msg;
ok !defined $res->{warnings}, $msg;
ok !defined $res->{command}, $msg;
cmp_deeply [grep { $_->{format} eq $error } @{ $res->{errors} }], [{%opts, format => $error}], $msg;
t/integration/config_engine_upload_file_real.t view on Meta::CPAN
{
my ($msg, $dir, $filename, $error, %opts) = @_;
assert_fails_on_filesystem $msg,
[qw!upload-file --config glacier.cfg --vault myvault --journal j!, '--filename', $filename, '--dir', $dir],
[],
$error, %opts;
}
sub with_save_dir(&)
{
my $curdir = Cwd::getcwd;
shift->();
chdir $curdir or confess;
}
sub with_my_dir($%)
{
my ($d, $cb, @dirs) = (shift, pop, @_);
my $dir = "$mtroot/$d";
with_save_dir {
mkpath binaryfilename $dir;
mkpath binaryfilename "$mtroot/$_" for (@dirs);
chdir binaryfilename $dir or confess;
$cb->($dir);
}
}
t/integration/fork_engine.t view on Meta::CPAN
my $rootdir = get_temp_dir();
my @TRUE_CMD = ($Config{'perlpath'}, '-e', '0');
print "# STARTED $$ ".time()."\n";
$SIG{ALRM} = sub { print STDERR "ALARM $$ ".time()."\n"; exit(1) };
sub fork_engine_test($%)
{
my ($cnt, %cb) = @_;
no warnings 'redefine';
local ($SIG{INT}, $SIG{USR1}, $SIG{USR2}, $SIG{TERM}, $SIG{HUP}, $SIG{CHLD});
local *App::MtAws::ForkEngine::run_children = sub {
alarm 40;
my ($self, $out, $in) = @_;
confess unless $self->{parent_pid};
$cb{child}->($in, $out, $self->{parent_pid}) if $cb{child};
t/integration/journal_parselines.t view on Meta::CPAN
archive_id => "HdGDbije6lWPT8Q8S3uOWJF6Ou9MWRlrfMGDr6TCrhXuDqJ1pzwKR6XV4l1IZ-VrDd2rlLxDFACqnuJouYTzsT5zd6s2ZEAHfRQFriVbjpFfJ1uWruHRRXIrFIma4PVuz-fp9_pBkA",
job_id => "HdGDbije6lWPT8Q8S3uOWJF6777MWRlrfMGDr688888888888zwKR6XV4l1IZ-VrDd2rlLxDFACqnuJouYTzsT5zd6s2ZEAHfRQFriVbjpFfJ1uWruHRRXIrFIma4PVuz-fp9_pBkA",
size => 7684356,
'time' => 1355666755,
mtime => 1355566755,
relfilename => 'def/abc',
treehash => '1368761bd826f76cae8b8a74b3aae210b476333484c2d612d061d52e36af631a',
};
sub create_journal(@)
{
open F, ">:encoding(UTF-8)", $journal;
print F for (@_);
close F;
}
sub assert_last_line_exception
{
t/lib/TestUtils.pm view on Meta::CPAN
}
};
}
sub get_temp_dir
{
$SIG{INT} = sub { exit(1); }; # Global signal, for cleaning temporary files
tempdir("__AppMtAws_t_${$}_XXXXXXXX", TMPDIR => 1, CLEANUP => 1); # pid needed cause child processes re-use random number generators
}
sub fake_config(@)
{
my ($cb, %data) = (pop @_, @_);
no warnings 'redefine';
local *App::MtAws::ConfigEngine::read_config = sub { %data ? { %data } : { (key=>'mykey', secret => 'mysecret', region => 'myregion') } };
disable_validations($cb);
}
sub no_disable_validations
{
local %disable_validations = ();
t/lib/TestUtils.pm view on Meta::CPAN
'override_validations' => {
journal => undef,
secret => undef,
key => undef,
dir => undef,
},
);
$cb->();
}
sub config_create_and_parse(@)
{
# use Data::Dumper;
# die Dumper {%disable_validations};
my $c = App::MtAws::ConfigDefinition::get_config(%disable_validations);
my $res = $c->parse_options(@_);
$res->{_config} = $c;
wantarray ? ($res->{error_texts}, $res->{warning_texts}, $res->{command}, $res->{options}) : $res;
}
sub capture_stdout($&)
{
local(*STDOUT);
my $enc = 'UTF-8';
$_[0]='';# perl 5.8.x issue warning if undefined $out is used in open() below
open STDOUT, '>', \$_[0] or die "Can't open STDOUT: $!";
binmode STDOUT, ":encoding($enc)";
my $res = $_[1]->();
close STDOUT;
$_[0] = decode($enc, $_[0], Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
$res;
}
sub capture_stderr($&)
{
local(*STDERR);
my $enc = 'UTF-8';
$_[0]='';# perl 5.8.x issue warning if undefined $out is used in open() below
open STDERR, '>', \$_[0] or die "Can't open STDERR: $!";
binmode STDOUT, ":encoding($enc)";
my $res = $_[1]->();
close STDERR;
$_[0] = decode($enc, $_[0], Encode::DIE_ON_ERR|Encode::LEAVE_SRC);
$res;
}
# TODO: call only as assert_raises_exception sub {}, $e - don't omit sub!
sub assert_raises_exception(&@)
{
my ($cb, $exception) = @_;
ok !defined eval { $cb->(); 1 };
my $err = $@;
cmp_deeply $err, superhashof($exception);
return ;
}
our $mock_order_declare;
our $mock_order_realtime;
t/lib/TestUtils.pm view on Meta::CPAN
die $@;
}
};
if ($test_fast_ok_cnt) {
ok 0, "$message - expected $plan tests, but ran ".($plan - $test_fast_ok_cnt);
} else {
ok (1, $message);
}
}
sub with_fork(&&)
{
my ($parent_cb, $child_cb) = @_;
my $ppid = $$;
my $fromchild = new IO::Pipe;
my $tochild = new IO::Pipe;
if (my $pid = fork()) {
my $child_exited = 0;
$fromchild->reader();
$fromchild->autoflush(1);
t/lib/TestUtils.pm view on Meta::CPAN
B::class(B::svref_2object(\$_[0]));
}
sub is_iv_without_pv
{
&get_pv_iv eq 'IV';
}
our $_cached_posix_root = undef;
sub is_posix_root()
{
$_cached_posix_root = do {
if ($^O eq 'cygwin') {
local ($!, $^E, $@);
eval {
require Win32;
Win32::IsAdminUser();
}
} else {
$> == 0;
}
} unless defined $_cached_posix_root;
$_cached_posix_root;
}
sub plan_tests($$)
{
my ($n, $cb) = @_;
if ($ENV{MT_STRESSTEST}){
plan tests => $ENV{MT_STRESSTEST};
for (1..$ENV{MT_STRESSTEST}) {
subtest("d$_", sub {
plan tests => $n;
$cb->();
});
my (undef, $mem) = `ps -p $$ -o rss`;
t/unit/config_engine_new.t view on Meta::CPAN
use Test::Spec;
use Encode;
use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use App::MtAws::ConfigEngine;
use Data::Dumper;
sub Context()
{
$App::MtAws::ConfigEngine::context
}
sub localize(&)
{
local $App::MtAws::ConfigEngine::context;
shift->();
}
describe "command" => sub {
it "should work" => sub {
localize sub {
my $code = sub { $_*2 };
t/unit/config_engine_parse.t view on Meta::CPAN
#
# This time we test both current config and current code together
#
my $max_concurrency = 30;
my $too_big_concurrency = $max_concurrency+1;
sub assert_config_throw_error($$$)
{
my ($config, $errorre, $text) = @_;
fake_config %$config => sub {
disable_validations 'journal' => sub {
my ($errors, $warnings, $command, $result) = config_create_and_parse(split(' ', $_ ));
ok( $errors && $errors->[0] =~ $errorre, $text);
}
}
}
t/unit/exceptions.t view on Meta::CPAN
is 'My message :NULL:', exception_message(exception 'code' => 'My message %04d a_42%', b_42 => 42);
is 'My message :NULL:', exception_message(exception 'code' => 'My message %a_42%', b_42 => 42);
is 'My message :NULL:', exception_message(exception 'code' => 'My message %string a_42%', b_42 => 42);
ok exception_message(exception 'code' => 'My message %string a_42%', a_42 => 42, c_42=>33);
# dump_error
sub test_error(&$$)
{
my ($cb, $where, $e) = @_;
capture_stderr my $out, sub {
eval { die $e };
dump_error($where);
};
$cb->($out, $@);
}
t/unit/exceptions.t view on Meta::CPAN
} '', 'somestring';
test_error {
my ($out, $err) = @_;
ok $out =~ /^UNEXPECTED ERROR \(here\): somestring/;
} 'here', 'somestring';
# TODO: check also that 'next' is called!
sub check_localized(&)
{
local $@ = 'checkme';
local $! = ENOMEM;
shift->();
is $@, 'checkme', "should not clobber eval error";
is $!+0, ENOMEM, "should not clobber errno";
}
# test get_errno with argument
{
t/unit/filter.t view on Meta::CPAN
'ss' => 'ß',
'ß' => 'ss',
);
is length('ß'), 1; # make sure we're running unicode
#
# _filters_to_pattern
#
sub assert_parse_filter_error($$)
{
my ($data, $err) = @_;
my $F = App::MtAws::Filter->new();
ok ! defined $F->_filters_to_pattern($data);
is $F->{error}, $err;
}
sub assert_parse_filter_ok(@)
{
my ($expected, @data) = (pop, @_);
my $F = App::MtAws::Filter->new();
ok !$F->{error};
cmp_deeply [$F->_filters_to_pattern(@data)], $expected;
}
my @spaces = ('', ' ', ' ');
my @onespace = ('', ' ');
t/unit/open_file.t view on Meta::CPAN
my $mtroot = get_temp_dir();
my $tmp_file = "$mtroot/open_file_test";
unlink $tmp_file;
rmtree $tmp_file;
sub new_stack(&)
{
local $OpenStack = [];
local $BinmodeStack = [];
shift->();
}
sub last_call()
{
$OpenStack->[0]
}
#
# mode
#
ok ! defined eval { open_file(my $f, $tmp_file); 1};
( run in 0.617 second using v1.01-cache-2.11-cpan-65fba6d93b7 )