• Your recent searches
App-MtAws
14 results

 view release on metacpan or  search on metacpan

lib/App/MtAws.pm  view on Meta::CPAN 

			die <<"END"
File with same name already exists in Journal.
In the current version of mtglacier you are disallowed to store multiple versions of same file.
Multiversion will be implemented in the future versions.
END
				if (defined $j->{journal_h}->{$relfilename});
			## use Test::Tabs

			if ($options->{'data-type'} ne 'filename') {
				binmode STDIN;
				check_stdin_not_empty(); # after we fork, but before we touch Journal for write and create Amazon Glacier upload id
			}

			$j->open_for_write();

			my $ft = ($options->{'data-type'} eq 'filename') ?
				App::MtAws::QueueJob::Upload->new(
					filename => $options->{filename}, relfilename => $relfilename,
					partsize => ONE_MB*$partsize, delete_after_upload => 0) :
				App::MtAws::QueueJob::Upload->new(
					stdin => 1, relfilename => $relfilename,

lib/App/MtAws.pm  view on Meta::CPAN 

	} elsif ($action eq 'version') {
		check_all_dynamic_modules();
		print "mt-aws-glacier version: $VERSION $VERSION_MATURITY\n";
		print "Perl Version: $]\n";
		print_system_modules_version();
	} else {
		die "Wrong usage";
	}
}

sub check_stdin_not_empty
{
	die "Empty input from STDIN - cannot upload empty archive"
		if eof(STDIN); # we block until first byte arrive, then we put it back in to buffer
}

1;

lib/App/MtAws/ConfigDefinition.pm  view on Meta::CPAN 

				}
			} elsif (present('dir')) {
				custom('relfilename', do {
					validate 'dir', 'filename';
					if (valid('dir') && valid('filename')) {

						my $b_dir = binary_abs_path(binaryfilename value('dir'));
						my $b_file = binary_abs_path(binaryfilename value('filename'));

						if (!defined $b_dir) {
							error(message('cannot_resolve_dir',
								'Directory specified with "%option a%" cannot be resolved to full path'),
								a => 'dir'), undef
						} elsif (!defined $b_file) {
							error(message('cannot_resolve_file',
								'File specified with "%option a%" cannot be resolved to full path'),
								a => 'filename'), undef;
						} else {
							my $relfilename = characterfilename abs2rel($b_file, $b_dir, allow_rel_base => 0, use_filename_encoding => 0);

							my $dir = value('dir');
							$dir =~ s!/$!!; # just in case

							confess "something wrong with relative-absolute paths"
								unless file_inodev(value('filename')) eq file_inodev($dir."/".$relfilename);

lib/App/MtAws/ConfigDefinition.pm  view on Meta::CPAN 

	$c->{preinitialize} = sub {
		set_filename_encoding $c->{options}{'filenames-encoding'}{value};
	};

	$c->define(sub {

		message 'no_command', 'Please specify command', allow_redefine=>1;
		message 'already_specified_in_alias', '%option b% specified, while %option a% already defined', allow_redefine => 1;
		message 'unexpected_argument', "Extra argument in command line: %a%", allow_redefine => 1;
		message 'mandatory', "Please specify %option a%", allow_redefine => 1;
		message 'cannot_read_config', 'Cannot read config file "%config%"';
		message 'deprecated_option', '%option% deprecated, use %main% instead';
		message 'option_for_command_can_be_used_only_with', "Option %option a% for %command c% command can be used only together with %option b%";


		for (option 'dir', deprecated => ['to-dir', 'from-dir']) {
			validation $_, message('%option a% should be less than 512 characters'), stop => 1, sub { length($_) < 512 }; # TODO: check that dir is dir
			validation $_, message('%option a% not a directory'), stop => 1, sub { -d binaryfilename };
		}

		option 'base-dir';

lib/App/MtAws/ConfigEngine.pm  view on Meta::CPAN 

		defined($context->{messages}->{$name}) ?
			{ format => $name, %data } :
			(%data ? confess("message '$name' is undefined") : $name);
	return;
};

sub read_config
{
	my ($self, $filename) = @_;
	-f $filename or
		die exception 'config_file_is_not_a_file' => "Config file is not a file: %config%",
		config => hex_dump_string($filename);
	open (my $F, "<:crlf", $filename) or
		die exception 'cannot_read_config' => "Cannot read config file: %config%, errno=%errno%",
		config => hex_dump_string($filename), 'ERRNO';
	my %newconfig;
	local $_;
	my $lineno = 0;
	while (<$F>) {
		chomp;
		++$lineno;
		next if /^\s*$/;
		next if /^\s*\#/;
		my ($name, $value);

lib/App/MtAws/IntermediateFile.pm  view on Meta::CPAN 

	$self->{_init_pid} = $$;
	return $self;
}

sub _init
{
	my ($self) = @_;
	my $dir  = dirname($self->{target_file});
	my $binary_dirname = binaryfilename $dir;
	eval { mkpath($binary_dirname); 1 } or do {
		die exception 'cannot_create_directory' =>
		'Cannot create directory %string dir%, errors: %error%',
		dir => $dir, error => hex_dump_string($@);
	};
	$self->{tmp} = eval {
		# PID is needed cause child processes re-use random number generators, improves performance only, no risk of race cond.
		File::Temp->new(TEMPLATE => "__mtglacier_temp${$}_XXXXXX", UNLINK => 1, SUFFIX => '.tmp', DIR => $binary_dirname)
	} or do {
		die exception 'cannot_create_tempfile' =>
		'Cannot create temporary file in directory %string dir%, errors: %error%',
		dir => $dir, error => hex_dump_string($@);
	};
	my $binary_tempfile = $self->{tmp}->filename;
	$self->{tempfile} = characterfilename($binary_tempfile);
	 # it's important to close file, it's filename can be passed to different process, and it can be locked
	close $self->{tmp} or confess;
}

sub tempfilename

lib/App/MtAws/IntermediateFile.pm  view on Meta::CPAN 

	my $binary_target_filename = binaryfilename($self->{target_file});

	my $character_tempfile = delete $self->{tempfile} or confess "file already permanent or not initialized";
	$self->{tmp}->unlink_on_destroy(0);
	undef $self->{tmp};
	my $binary_tempfile = binaryfilename($character_tempfile);

	chmod((0666 & ~umask), $binary_tempfile) or confess "cannot chmod file $character_tempfile";
	utime $self->{mtime}, $self->{mtime}, $binary_tempfile or confess "cannot change mtime for $character_tempfile" if defined $self->{mtime};
	rename $binary_tempfile, $binary_target_filename or
		die exception "cannot_rename_file" => "Cannot rename file %string from% to %string to%",
		from => $character_tempfile, to => $self->{target_file};
}

# File::Temp < 0.19 does not have protection from calling destructor in fork'ed child
# and forking can happen any moments, some code in File::Spec/Cwd etc call it to exec external commands
# this workaround prevents this, however destruction order is undefined so that might just fail

# we can try use File::Temp::tempfile() but it destroys temp files only on program exit
# (can workaround with DESTROY) + when handle is closed! (thats bad)
sub DESTROY

lib/App/MtAws/QueueJob/MultipartPart.pm  view on Meta::CPAN 


		my $part_final_hash = $part_th->get_final_hash();
		my $start = $self->{position};
		my $attachment = \$data,

		$self->{th}->eat_data(\$data);
		$self->{position} += $r;

		return (1, $start, $part_final_hash, $attachment);
	} else {
		die exception 'cannot_read_from_file' => "Cannot read from file errno=%errno%", 'ERRNO'  unless defined $r;
		return;
	}


}

sub get_part
{
	my ($self) = @_;

lib/App/MtAws/Utils.pm  view on Meta::CPAN 

	my $result = File::Spec->abs2rel($path, $base);
	$args{use_filename_encoding} ? characterfilename($result) : $result;
}


=head1 open_file(my $f, $filename, %args)

$args{mode} - mode to open, <, > or >>
$args{use_filename_encoding} - (TRUE) - encode to binary string, (FALSE) - don't tocuh (already a binary string). Default TRUE
$args{file_encoding} or $args{binary} - file content encoding or it's a binary file (mutual exclusive)
$args{not_empty} - assert that file is not empty after open

Assertions made (using "confess"):

1) Bad arguments (programmer's error)
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});
	confess "unknown mode $args{mode}" unless $args{mode} =~ m!^\+?(<|>>?)$!;
	my $mode = $args{mode};

	confess "not_empty can be used in read mode only"
		if ($args{not_empty} && $args{mode} ne '<');


	if (defined($args{file_encoding})) {
		$mode .= ":encoding($args{file_encoding})";
		confess "cannot use binary and file_encoding at same time'" if $args{binary};
	} elsif (!$args{binary}) {
		confess "there should be file encoding or 'binary'";
	}

	if ($args{use_filename_encoding}) {
		$filename = binaryfilename $filename;
	}

	confess "File is not a plain file" if -e $filename && (! -f $filename);
	confess "File should not be empty" if $args{not_empty} && (! -s $filename);

	open ($_[0], $mode, $filename) or return;
	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, @_);

t/integration/config_engine_config_file.t  view on Meta::CPAN 

	skip "Cannot run under root", 6 if is_posix_root;
	rmtree($file);
	open F, ">", $file;
	print F " ";
	close F;
	chmod 0000, $file;
	disable_validations sub {
		ok ! defined eval { config_create_and_parse(@line); 1; };
		my $err = get_exception();
		ok $err;
		is $err->{code}, 'cannot_read_config';
		is $err->{config}, hex_dump_string($file);
		is $err->{errno}, get_errno(POSIX::strerror(EACCES));
		is exception_message($err), "Cannot read config file: ".hex_dump_string($file).", errno=".get_errno(POSIX::strerror(EACCES));
	};
}

{
	rmtree($file);
	mkpath($file);
	disable_validations sub {
		ok ! defined eval { config_create_and_parse(@line); 1; };
		my $err = get_exception();
		ok $err;
		is $err->{code}, 'config_file_is_not_a_file';
		is $err->{config}, hex_dump_string($file);
		is exception_message($err), "Config file is not a file: ".hex_dump_string($file);
	}
}

{
	rmtree($file);
	open F, ">", $file;
	close F;
	disable_validations sub {

t/integration/config_engine_upload_file_real.t  view on Meta::CPAN 


	test_file_and_dir "dir/filename should work with symlinks 8",
		"ds", "ds/d4/myfile2", "d4/myfile2";

	test_file_and_dir "dir/filename should work with symlinks 8",
		"ds/", "ds/d4/myfile2", "d4/myfile2";
};


my @filename_inside_dir = ('filename_inside_dir', a => 'filename', b => 'dir');
my @not_a_file = ('%option a% not a file', a => 'filename');
my @not_a_dir = ('%option a% not a directory', a => 'dir');

with_my_dir "d1/d2", "d1/d2/d3", sub {
	my ($curdir) = @_;

	touch "../myfile1";
	touch "myfile2";
	touch "d3/myfile3";

	fails_file_and_dir "filename inside dir",
		"d3", "myfile2", @filename_inside_dir;

t/integration/config_engine_upload_file_real.t  view on Meta::CPAN 

	fails_file_and_dir "filename inside dir",
		"$curdir/d3", "$curdir/myfile2", @filename_inside_dir;

	fails_file_and_dir "filename inside dir",
		"d3", "../myfile1", @filename_inside_dir;

	fails_file_and_dir "filename inside dir",
		".", "../myfile1", @filename_inside_dir;

	fails_file_and_dir "file not found",
		".", "../notafile", @not_a_file, value => '../notafile';

	fails_file_and_dir "file not found",
		"d3", "../notafile", @not_a_file, value => '../notafile';

	fails_file_and_dir "file not found",
		"d3", "notafile", @not_a_file, value => 'notafile';

	fails_file_and_dir "filename inside dir",
		"notadir", "myfile2", @not_a_dir, value => 'notadir';

	fails_file_and_dir "filename inside dir",
		"$curdir/notadir", "$curdir/myfile2", @not_a_dir, value => "$curdir/notadir";

	fails_file_and_dir "filename inside dir",
		"notadir", "notafile", @not_a_dir, value => 'notadir';

	# TODO: test also for bad filename
	fails_file_and_dir "filename inside dir",
		('x' x 2048), "myfile2", '%option a% should be less than 512 characters', a => 'dir', value => ("x" x 2048);

};

SKIP: {
	skip "Cannot run under root", 24 if $^O eq 'cygwin' || is_posix_root; # too britle even under cygwin non-root

t/integration/config_engine_upload_file_real.t  view on Meta::CPAN 

			"$mtroot/restricted/normal", $file_rel, $file_rel;

		chmod 000, $restricted_abs;

		ok  -f $file_rel;
		ok !-f $file_abs;
		ok !-d $normal_rel;
		ok !-d $normal_abs;

		fails_file_and_dir "filename inside dir - dir is unresolvable",
			"another/..", $file_rel, 'cannot_resolve_dir', a => 'dir';

		fails_file_and_dir "filename inside dir - file is unresolvable",
			$mtroot, $file_rel, 'cannot_resolve_file', a => 'filename';

		chmod 700, $restricted_abs;
	}
};

# TODO: also test with non-ascii filenames
with_my_dir "d1", sub {
	touch "myfile";
	touch "unreadable";
	touch "empty", "";

t/integration/config_read_config.t  view on Meta::CPAN 

	my $vars2 = { 'mykey1' => $value, 'mykey2' => 'myvalue2'};
	is_deeply(read_as_config("mykey1=$value\nmykey2=myvalue2"), $vars2, "should allow equal sign in values");
}

{
	unlink $file if -e $file;
	ok ! -e $file, "assert we deleted file";
	my $C = App::MtAws::ConfigEngine->new();
	ok !defined eval { $C->read_config($file); 1 };
	ok get_exception;
	is get_exception->{code}, 'config_file_is_not_a_file';
	is get_exception->{config}, hex_dump_string($file);
	is exception_message(get_exception), "Config file is not a file: ".hex_dump_string($file);
}

{
	unlink $file;
	rmtree($file) if -d $file;
	mkpath($file);
	ok -d $file, "assert file is directory";
	my $C = App::MtAws::ConfigEngine->new();
	ok !defined eval { $C->read_config($file); 1;};
	ok get_exception;
	is get_exception->{code}, 'config_file_is_not_a_file';
	is get_exception->{config}, hex_dump_string($file);
	is exception_message(get_exception), "Config file is not a file: ".hex_dump_string($file);

}

sub read_as_config
{
	my ($bytes) = @_;
	open F, ">", $file;
	binmode F;

t/integration/queue_job/multipart_part_ioerr.t  view on Meta::CPAN 

create($filename, 'x');

open my $f, "<", $filename or die;
my $j = bless { fh => $f, position => 0, partsize => 1, th => bless { mock => 'global'}, 'App::MtAws::TreeHash' },
	'App::MtAws::QueueJob::MultipartPart';

my $expect_err = get_errno(POSIX::strerror(2));
ok ! eval { $j->read_part(); 1; };
my $err = $@;

is $err->{code}, 'cannot_read_from_file';
is $err->{errno_code}, 2;
is $err->{errno}, $expect_err;
is exception_message($err), "Cannot read from file errno=".$expect_err;


1;

t/unit/cmd_check_local_hash.t  view on Meta::CPAN 

			};
		};
		it "should work when treehash does not match" => sub {
			ordered_test sub {
				expect_read_journal $j, $file1;

				expect_file_exists $file1->{relfilename};
				expect_file_size $file1->{relfilename}, $file1->{size};
				expect_file_mtime $file1->{relfilename}, $file1->{mtime};
				expect_open_file my $fileobj = { mock => 1 }, $file1->{relfilename}, 1;
				expect_treehash $fileobj, "not_a_treehash";

				my ($res, $out) = run_command($options, $j);
				ok !$res;
				ok $out =~ /^TREEHASH MISSMATCH file1$/m;
				check_ok($out, qw/treehash/);
			};
		};
		it "should work when mtime does not match" => sub {
			ordered_test sub {
				expect_read_journal $j, $file1;

t/unit/exceptions.t  view on Meta::CPAN 


	is $App::MtAws::Exceptions::_errno_encoding, App::MtAws::Exceptions::BINARY_ENCODING(),
		"BINARY encoding should be reused";
}

{
	local $App::MtAws::Exceptions::_errno_encoding = undef;
	my $test_str = encode("UTF-8", "тест");
	no warnings 'redefine';

	my $not_encoding = "NOT_AN_ENCODING";
	ok !defined find_encoding($not_encoding);

	local *I18N::Langinfo::langinfo = sub { $not_encoding };
	check_localized {
		is get_errno($test_str), hex_dump_string($test_str), "get_errno should work encoding is unknown";
	};

	is $App::MtAws::Exceptions::_errno_encoding, App::MtAws::Exceptions::BINARY_ENCODING(),
		"should be a binary encoding, when encoding is unknown";

	local *I18N::Langinfo::langinfo = sub { "UTF-8" };
	check_localized {
		get_errno($test_str);

t/unit/intermediate_file.t  view on Meta::CPAN 


	ok ! -e $permanent_name, "assume permanent file not yet exists";
	$I->make_permanent;
	ok ! defined eval { $I->make_permanent; 1; }, "should confess if make_permanent called twice";
	like $@, qr/file already permanent or not initialized/, "should confess with right message if make_permanent called twice";

}

{
	ok ! -e do {
		my $I = App::MtAws::IntermediateFile->new(target_file => "$rootdir/something_not_existant");
		my $filename = $I->tempfilename;
		ok -f $filename, "should create temp file";
		$filename;
	}, "file auto-removed";
}

for (['a'], ['b','c'], ['b', 'c', 'd'], ['e', 'f', 'g']) {
	my $subdir = join('/', @$_);
	my $fulldir = "$rootdir/$subdir";
	my $perm_file = "$fulldir/permfile";

t/unit/intermediate_file.t  view on Meta::CPAN 


}

SKIP: {
	skip "Cannot run under root", 5 if is_posix_root;
	my $dir = "$rootdir/denied1";
	ok mkpath($dir), "path is created";
	ok -d $dir, "path is created";;
	chmod 0444, $dir;
	ok ! defined eval { App::MtAws::IntermediateFile->new(target_file => "$dir/somefile"); 1 }, "File::Temp should throw exception";
	is get_exception->{code}, 'cannot_create_tempfile', "File::Temp correct code for exception";
	is get_exception->{dir}, $dir, "File::Temp correct dir for exception";
}

SKIP: {
	skip "Cannot run under root", 5 if is_posix_root;
	my $dir = "$rootdir/denied2";
	ok mkpath($dir), "path is created";
	ok -d $dir, "path is created";;
	chmod 0444, $dir;
	ok ! defined eval { App::MtAws::IntermediateFile->new(target_file => "$dir/b/c/somefile"); 1 }, "mkpath() should throw exception";
	is get_exception->{code}, 'cannot_create_directory', "mkpath correct code for exception";
	is get_exception->{dir}, "$dir/b/c", "mkpath correct dir for exception";
}

SKIP: {
	skip "Cannot run under root", 7 if is_posix_root;
	my $dir = "$rootdir/testpermanent";
	ok ! -e $dir, "not yet exists";
	ok mkpath($dir), "path is created";
	ok -d $dir, "path is created";
	my $dest = "$dir/dest";
	mkdir "$dir/dest";
	my $I = App::MtAws::IntermediateFile->new(target_file => $dest);
	my $tmpfile = $I->tempfilename;
	ok ! defined eval { $I->make_permanent; 1 }, "should throw exception if cant rename files";
	is get_exception->{code}, 'cannot_rename_file', "correct exception code";
	is get_exception->{from}, $tmpfile, "correct exception 'from'";
	is get_exception->{to}, $dest, "correct exception 'to'";
}

{
	is get_filename_encoding, 'UTF-8', "assume utf8 encoding is set";
	my $dir = "$rootdir/тест2";
	my $I = App::MtAws::IntermediateFile->new(target_file => "$dir/somefile");
	like $I->tempfilename, qr/\Q$dir\E/, "filename should contain directory name, thus be in UTF8";
	ok -d $dir, "dir in UTF-8 should not exist";

t/unit/open_file.t  view on Meta::CPAN 

};

#
# other args
#

ok ! defined eval { open_file(my $f, $tmp_file, mode => '>', binary => 1, zz => 123); 1};
ok $@ =~ /Unknown argument/;

#
# not_empty
#

ok ! defined eval { open_file(my $f, $tmp_file, mode => '>', binary => 1, not_empty => 1); 1};
ok $@ =~ /not_empty can be used in read mode only/;

create_tmp_file();
ok defined eval { open_file(my $f, $tmp_file, mode => '<', binary => 1, not_empty => 1); 1};
unlink $tmp_file;

#
# binary and file_encoding
#

ok ! defined eval { open_file(my $f, $tmp_file, mode => '>', binary => 1, file_encoding => 'UTF-8'); 1};
ok $@ =~ /cannot use binary and file_encoding at same time/;

ok ! defined eval { open_file(my $f, $tmp_file, mode => '>'); 1};

t/unit/open_file.t  view on Meta::CPAN 

{
	unlink $tmp_file;
	mkpath $tmp_file;
	ok ! defined eval { open_file(my $f, $tmp_file, mode => '>', binary => 1); 1 };
	ok $@ =~ /not a plain file/i;
	rmtree $tmp_file;
}

{
	create_tmp_file("");
	ok ! defined eval { open_file(my $f, $tmp_file, mode => '<', binary => 1, not_empty=>1); 1 };
	ok $@ =~ /should not be empty/i;
	unlink $tmp_file;
}


unlink $tmp_file;
{
	ok ! defined open_file(my $f, $tmp_file, mode => '<', binary => 1);
}



( run in 0.769 second using v1.01-cache-2.11-cpan-0a987023a57 )