File Coverage

lib/App/MtAws/HttpSegmentWriter.pm

Criterion	Covered	Total	%
statement	124	175	70.8
branch	12	40	30.0
condition	2	6	33.3
subroutine	35	49	71.4
pod	0	6	0.0
total	173	276	62.6

# mt-aws-glacier - Amazon Glacier sync client
# Copyright (C) 2012-2014  Victor Efimov
# http://mt-aws.com (also http://vs-dev.com) [e-mail]
# License: GPLv3
#
# This file is part of "mt-aws-glacier"
#
#    mt-aws-glacier is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    mt-aws-glacier is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

package App::MtAws::HttpWriter;

our $VERSION = '1.114_2';

use strict;
use warnings;
use utf8;
use Carp;
use App::MtAws::TreeHash;


sub new
{
	my ($class, %args) = @_;
	my $self = \%args;
	bless $self, $class;
	$self->initialize();
	return $self;
}

sub initialize
{
	my ($self) = @_;
	$self->{write_threshold} = 2*1024*1024;
}

sub reinit
{
	my ($self, $size) = @_;
	$self->{size}=$size;
	$self->{totalsize}=0;
	$self->{total_commited_length} = $self->{pending_length} = $self->{total_length} = 0;
	$self->{buffer} = '';
}

sub add_data
{
	my $self = $_[0];
	return unless defined($_[1]);
	my $len = length($_[1]);
	$self->{buffer} .= $_[1];
	$self->{pending_length} += $len;
	$self->{total_length} += $len;
	if ($self->{pending_length} > $self->{write_threshold}) {
		$self->_flush();
	}
	1;
}

sub _flush
{
	confess "not implemented";
}

sub treehash
{
	undef;
}

sub _flush_buffers
{
	my ($self, @files) = @_;
	my $len = length($self->{buffer});
	for my $fh (@files) {
		print $fh $self->{buffer} or confess "cant write to file $!";
	}
	if (my $th = $self->treehash) {
		$th->eat_data_any_size($self->{buffer});
	}
	$self->{total_commited_length} += $len;
	$self->{buffer} = '';
	$self->{pending_length} = 0;
	$len;
}

sub finish
{
	my ($self) = @_;
	$self->_flush();
	$self->{total_commited_length} == $self->{total_length} or confess;
	return ($self->{total_length} && ($self->{total_length} == $self->{size})) ? ('ok') : ('retry', 'Unexpected end of data');
}

package App::MtAws::HttpSegmentWriter;

our $VERSION = '1.114_2';

use strict;
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;
	bless $self, $class;
	$self->SUPER::initialize();
	$self->initialize();
	return $self;
}

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

sub reinit
{
	my $self = shift;
	$self->{incr_position} = 0;
	$self->{treehash} = App::MtAws::TreeHash->new();
	$self->SUPER::reinit(@_);
}

sub treehash { shift->{treehash} }

sub _flush
{
	my ($self) = @_;
	if ($self->{pending_length}) {
		open_file(my $fh, $self->{tempfile}, mode => '+<', binary => 1) or delayed_confess "cant open file $self->{tempfile} $!";
		flock $fh, LOCK_EX or delayed_confess;
		$fh->flush();
		$fh->autoflush(1);
		seek $fh, $self->{position}+$self->{incr_position}, SEEK_SET or delayed_confess "cannot seek() $!";
		$self->{incr_position} += $self->_flush_buffers($fh);
		close $fh or delayed_confess; # close will unlock
	}
}

sub finish
{
	my ($self) = @_;
	my @r = $self->SUPER::finish();
	return @r;
}


package App::MtAws::HttpFileWriter;

our $VERSION = '1.114_2';

use strict;
use warnings;
use utf8;
use App::MtAws::Utils;
use Carp;
use base qw/App::MtAws::HttpWriter/;


sub new
{
	my ($class, %args) = @_;
	my $self = \%args;
	bless $self, $class;
	$self->SUPER::initialize();
	$self->initialize();
	return $self;
}

sub initialize
{
	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}) {
		$self->_flush_buffers($self->{fh});
	}
}

sub finish
{
	my ($self) = @_;
	my @r = $self->SUPER::finish();
	close $self->{fh} or confess;
	return @r;
}


package App::MtAws::HttpMemoryWriter;

our $VERSION = '1.114_2';

use strict;
use warnings;
use utf8;
use App::MtAws::Utils;
use Carp;
use base qw/App::MtAws::HttpWriter/;


sub new
{
	my ($class, %args) = @_;
	my $self = {};
	bless $self, $class;
	return $self;
}

sub reinit
{
	my $self = shift;
	$self->{size} = shift;
	$self->{buffer} = '';
	$self->{total_length} = 0;
}

sub add_data
{
	my $self = $_[0];
	return unless defined($_[1]);
	$self->{buffer} .= $_[1];
	$self->{total_length} += length($_[1]);
	1;
}

sub finish
{
	my ($self) = @_;
	return ($self->{total_length} && ($self->{total_length} == $self->{size})) ? ('ok') : ('retry', 'Unexpected end of data');
}

1;