File Coverage

perllib/Arch/Tarball.pm

Criterion	Covered	Total	%
statement	12	45	26.6
branch	0	14	0.0
condition	0	20	0.0
subroutine	4	8	50.0
pod	4	4	100.0
total	20	91	21.9

# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman
#
# This program 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 2 of the License, or
# (at your option) any later version.
#
# This program 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use 5.005;
use strict;

package Arch::Tarball;

use Arch::Util qw(run_cmd run_pipe_from copy_dir);
use Arch::TempFiles qw(temp_dir);

sub new ($%) {
	my $class = shift;
	my %init = @_;

	my $self = {
		tar => $init{tar} || "tar",
		file => $init{file},
	};

	bless $self, $class;
	return $self;
}

sub create ($%) {
	my $self = shift;
	my %args = @_;
	my $dir = $args{dir};
	die "Arch::Tarball::create: no dir given\n"
		unless $dir;
	die "Arch::Tarball::create: bad dir ($dir)\n"
		unless -d $dir && $dir =~ s!^(.+)/(.+)$!$1!;
	my $base_name = $2;
	my $needed_base_name = $args{base_name};
	die "Arch::Tarball::create: bad base_name ($needed_base_name)\n"
		if $needed_base_name && $needed_base_name =~ m!/!;
	my $do_pipe = $args{pipe};
	die "Arch::Tarball::create: non-pipe is not implemented yet\n"
		unless $do_pipe;

	if ($needed_base_name && $needed_base_name ne $base_name) {
		my $temp_dir = temp_dir("arch-tarball");
		copy_dir("$dir/$base_name", "$temp_dir/$needed_base_name");
		$base_name = $needed_base_name;
		$dir = $temp_dir;
	}

	my @tar_args = ($self->{tar}, "czf", "-", "-C", $dir, $base_name);
	my $tar_pipe = run_pipe_from(@tar_args);
	return $tar_pipe;
}

sub extract ($%) {
	my $self = shift;
	my %args = @_;

	my $file = $args{file} || $self->{file}
		or die "Arch::Tarball::extract: No file given in constructor\n";
	my $dir = $args{dir} || temp_dir("arch-tarball");
	die "Arch::Tarball::extract: unexisting dir ($dir)\n"
		if $args{dir} && !-d $dir;

	run_cmd($self->{tar}, "xz", "-C", $dir, "-f", $file);

	return $dir;
}

sub list ($%) {
	my $self = shift;
	my %args = @_;
	die "Not implemented yet";
}

1;

__END__