view release on metacpan or  search on metacpan

perllib/Arch/Session.pm  view on Meta::CPAN

# 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::Session;

use base 'Arch::Storage';

use Arch::Util qw(run_tla _parse_revision_descs load_file save_file);
use Arch::Backend qw(get_cache_config);
use Arch::TempFiles qw(temp_dir_name temp_dir);
use Arch::Changeset;
use Arch::Library;
use Arch::Log;
use Arch::Tree;
use Arch::Tarball;

sub _default_fields ($) {
	my $this = shift;
	return (
		$this->SUPER::_default_fields,
		use_library => 1,
	);
}

sub new ($%) {
	my $class = shift;
	my %init = @_;
	my $self = $class->SUPER::new(%init);
	$self->clear_cache;
	return $self;
}

sub archives ($) { 
	my $self = shift;
	$self->{archives} ||= [ run_tla("archives -n") ];
	return $self->{archives};
}
 
*is_archive_registered = *Arch::Storage::is_archive_managed;
*is_archive_registered = *is_archive_registered;

sub categories ($;$) {
	my $self = shift;
	my $archive = $self->_name_operand(shift, 'archive');

	unless ($self->{categories}->{$archive}) {
		$self->{categories}->{$archive} = [ run_tla("categories", $archive) ];
	}
	return $self->{categories}->{$archive};
}

sub branches ($;$) {
	my $self = shift;
	my $category = $self->_name_operand(shift, 'category');

	unless ($self->{branches}->{$category}) {
		$self->{branches}->{$category} = [ run_tla("branches", $category) ];
	}
	return $self->{branches}->{$category};
}

sub versions ($;$) {
	my $self = shift;
	my $branch = $self->_name_operand(shift, 'branch');

	unless ($self->{versions}->{$branch}) {
		$self->{versions}->{$branch} = [ run_tla("versions", $branch) ];
		# temporarily do this for backward compatibility
		$self->{versions}->{$branch} = [ map { s/--/----/; $_ } grep !/--.*--/, @{$self->{versions}->{$branch}} ]
			if $branch->branch eq '';
	}
	return $self->{versions}->{$branch};
}

sub revisions ($;$) {
	my $self = shift;
	my $version = $self->_name_operand(shift, 'version');

	unless ($self->{revisions}->{$version}) {
		$self->{revisions}->{$version} = [ run_tla("revisions", $version) ];
	}
	return $self->{revisions}->{$version};
}

sub get_revision_descs ($;$$) {
	my $self = shift;
	my $version = $self->_name_operand(shift, 'version');
	my $extra_args = shift || [];