App-MtAws

 view release on metacpan or  search on metacpan

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

		}
	}
	if ($res->{error_texts}) {
		for (@{$res->{error_texts}}) {
			print STDERR "ERROR: ".$_."\n";
		}
		die exception cmd_error => 'Error in command line/config'
	}
	if ($action ne 'help' && $action ne 'version') {
		$PerlIO::encoding::fallback = Encode::FB_QUIET;
		binmode STDERR, ":encoding($options->{'terminal-encoding'})";
		binmode STDOUT, ":encoding($options->{'terminal-encoding'})";
	}

	my %journal_opts = ( journal_encoding => $options->{'journal-encoding'} );

	if ($action eq 'sync') {
		die "Not a directory $options->{dir}" unless -d binaryfilename $options->{dir};

		my $j = App::MtAws::Journal->new(%journal_opts, journal_file => $options->{journal}, root_dir => $options->{dir},
			filter => $options->{filters}{parsed}, leaf_optimization => $options->{'leaf-optimization'}, follow => $options->{'follow'});

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

			## no Test::Tabs
			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(

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

	#log("created tochild pipe $!", 10) if level(10);
	my $pid;
	my $parent_pid = $$;

	if($pid = fork()) { # Parent
		$|=1;
		STDERR->autoflush(1);
		$fromchild->reader();
		$fromchild->autoflush(1);
		$fromchild->blocking(1);
		binmode $fromchild;

		$tochild->writer();
		$tochild->autoflush(1);
		$tochild->blocking(1);
		binmode $tochild;

		$disp_select->add($fromchild);
		$self->{children}->{$pid} = { pid => $pid, fromchild => $fromchild, tochild => $tochild };

		print "PID $pid Started worker\n";
		return (0, undef, undef);
	} elsif (defined ($pid)) { # Child
		$|=1;
		STDERR->autoflush(1);
		$fromchild->writer();
		$fromchild->autoflush(1);
		$fromchild->blocking(1);
		binmode $fromchild;

		$tochild->reader();
		$tochild->autoflush(1);
		$tochild->blocking(1);
		binmode $tochild;

		undef $disp_select; # we discard tonns of unneeded pipes !
		undef $self->{children};

		return (1, $fromchild, $tochild);
	} else {
		die "Cannot fork()";
	}
}

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

{
	my ($self) = @_;
	defined($self->{tempfile}) or confess;
}

sub reinit
{
	my $self = shift;
	undef $self->{fh};
	open_file($self->{fh}, $self->{tempfile}, mode => '+<', binary => 1) or confess "cant open file $self->{tempfile} $!";
	binmode $self->{fh};
	$self->{treehash} = App::MtAws::TreeHash->new();
	$self->SUPER::reinit(@_);
}

sub treehash { shift->{treehash} }

sub _flush
{
	my ($self) = @_;
	if ($self->{pending_length}) {

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

	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, @_);
	if ($args{use_filename_encoding}) {
		$filename = binaryfilename $filename;

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

if(can_work_with_non_utf8_files) {
	plan tests => 5250;
} else {
	plan skip_all => 'Test cannot be performed on character-oriented filesystem';
}


binmode Test::More->builder->output, ":utf8";
binmode Test::More->builder->failure_output, ":utf8";

my $mtroot = get_temp_dir();
my $tmproot = "$mtroot/журнал-byteenc";
my $dataroot = "$tmproot/dataL1/данныеL2";
my $journal_file = "$tmproot/journal";

my $pwd  = Cwd::getcwd();


# -0.* -Ñ„exclude/a/ +*.gz -

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

	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;
	print F $bytes;
	close F;
	my $C = App::MtAws::ConfigEngine->new();
	my $r = $C->read_config($file);
	return undef unless defined $r;
	return ({map { decode("UTF-8", $_)  } %$r}); # UTF-8 decode hash
}


1;

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

my $fromchild = new IO::Pipe;
my $tochild = new IO::Pipe;

sub _flock { flock($_[0], $_[1]); }

if (fork()) {
	$fromchild->reader();
	$fromchild->autoflush(1);
	$fromchild->blocking(1);
	binmode $fromchild;

	$tochild->writer();
	$tochild->autoflush(1);
	$tochild->blocking(1);
	binmode $tochild;

	open_file(my $fh, $filename, mode => '+<', binary => 1);
	print $tochild "open\n";
	_flock $fh, LOCK_EX or confess;
	$fh->flush();
	$fh->autoflush(1);
	print $fh "1234\n";
	print $tochild "lock\n";
	usleep(300);
	seek $fh, 0, SEEK_SET;
	print $fh "ABCD\n";
	flock $fh, LOCK_UN or confess;
	is scalar <$fromchild>, "OK\n"
} else {
	$fromchild->writer();
	$fromchild->autoflush(1);
	$fromchild->blocking(1);
	binmode $fromchild;

	$tochild->reader();
	$tochild->autoflush(1);
	$tochild->blocking(1);
	binmode $tochild;

	confess unless (scalar <$tochild> eq "open\n");
	open_file(my $fh, $filename, mode => '+<', binary => 1) or confess;
	confess unless (scalar <$tochild> eq "lock\n");
	_flock $fh, LOCK_EX or confess;
	$fh->flush();
	$fh->autoflush(1);
	seek $fh, 0, SEEK_SET;
	confess unless (scalar <$fh> eq "ABCD\n");
	print $fromchild "OK\n";

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

use FindBin;
use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use App::MtAws::Journal;
use File::Path;
use JournalTest;
use open qw/:std :utf8/; # actually, we use "UTF-8" in other places.. UTF-8 is more strict than utf8 (w/out hypen)



binmode Test::Simple->builder->output, ":utf8";
binmode Test::Simple->builder->failure_output, ":utf8";

my $mtroot = get_temp_dir();
my $tmproot = "$mtroot/журнал-utf";
my $dataroot = "$tmproot/dataL1/данныеL2";
my $journal_file = "$tmproot/journal";



rmtree($tmproot) if ($tmproot) && (-d $tmproot);
mkpath($dataroot);

t/lib/TestUtils.pm  view on Meta::CPAN

	$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) = @_;

t/lib/TestUtils.pm  view on Meta::CPAN

	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);
		$fromchild->blocking(1);
		binmode $fromchild;

		$tochild->writer();
		$tochild->autoflush(1);
		$tochild->blocking(1);
		binmode $tochild;

		alarm ALARM_FOR_FORK_TESTS; # protect from hang in case our test fail
		$parent_cb->($fromchild, $tochild, $pid);
		alarm 0;

		while(wait() != -1 ){};
	} else {
		$fromchild->writer();
		$fromchild->autoflush(1);
		$fromchild->blocking(1);
		binmode $fromchild;

		$tochild->reader();
		$tochild->autoflush(1);
		$tochild->blocking(1);
		binmode $tochild;

		alarm ALARM_FOR_FORK_TESTS; # protect from hang in case our test fail
		$child_cb->($tochild, $fromchild, $ppid);
		alarm 0;

		exit(0);
	}
}

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

use Test::More tests => 50;
use Test::Deep;
use Encode;
use FindBin;

# before 'use xxx Utils'
our $OpenStack = undef;
our $BinmodeStack = undef;
sub _open { CORE::open($_[0], $_[1], $_[2]) };
BEGIN { no warnings 'once'; *CORE::GLOBAL::open = sub(*;$@) { push @$OpenStack, \@_; _open(@_) }; };
BEGIN { no warnings 'once'; *CORE::GLOBAL::binmode = sub(*;$) { push @$BinmodeStack, \@_; CORE::binmode($_[0]) }; };


use lib map { "$FindBin::RealBin/$_" } qw{../lib ../../lib};
use TestUtils 'w_fatal';
use Data::Dumper;
use File::Path;


use App::MtAws::Utils;
use App::MtAws::Exceptions;

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

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

unlink $tmp_file;


sub create_tmp_file
{
	CORE::open F, ">", $tmp_file;
	binmode F;
	print F @_ ? shift : "1\n";
	close F;

}

1;