File Coverage

perllib/Arch/Inventory.pm

Criterion	Covered	Total	%
statement	61	136	44.8
branch	0	36	0.0
condition	0	17	0.0
subroutine	21	33	63.6
pod	9	9	100.0
total	91	231	39.3

# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman, Enno Cramer
#
# 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::Inventory;

use Exporter;
BEGIN { *Arch::Inventory::import = *Exporter::import; }
use vars qw(@EXPORT_OK %EXPORT_TAGS);

@EXPORT_OK = qw(
	TREE SOURCE PRECIOUS BACKUP JUNK UNRECOGNIZED
	FILE DIRECTORY SYMLINK
	TAGLINE EXPLICIT NAME
);
%EXPORT_TAGS = (
	category => [ qw(TREE SOURCE PRECIOUS BACKUP JUNK UNRECOGNIZED) ],
	type     => [ qw(FILE DIRECTORY SYMLINK) ],
	id_type  => [ qw(TAGLINE EXPLICIT NAME) ],
);


use Arch::Util qw(run_tla);

use constant TREE         => 'T';
use constant SOURCE       => 'S';
use constant PRECIOUS     => 'P';
use constant BACKUP       => 'B';
use constant JUNK         => 'J';
use constant UNRECOGNIZED => 'U';

use constant FILE         => 'r';
use constant DIRECTORY    => 'd';
use constant SYMLINK      => '>';

use constant TAGLINE      => 'i';
use constant EXPLICIT     => 'x';
use constant NAMES        => '?';
use constant ARCH_CONTROL => 'A';
use constant ARCH_ID_DIR  => 'D';
use constant ARCH_ID_FILE => 'E';

sub new ($$) {
	my $class = shift;
	my $dir   = shift || ".";

	$dir =~ s!/$!!;

	die(__PACKAGE__ . ": directory $dir does not exist\n") unless -d $dir;

	my $prefix = $dir . '/';
	my $plen   = length($prefix);

	# parse inventory output
	my @inv_temp    = run_tla(qw{inventory -spbju -B --kind --ids}, $dir);
	my @inv_entries = ();
	foreach my $line (@inv_temp) {
		$line =~ /^([TSPBJU])([? ]) ([rd>]) ([^\t]+)\t(.+)$/
			or die "Unrecognized inventory line: $line\n";

		my $path = (length($4) > $plen) && (substr($4, 0, $plen) eq $prefix) ? substr($4, $plen) : $4;

		push @inv_entries, {
			category => $1,
			untagged => $2 eq '?',
			type     => $3,
			path     => $path,
			id       => $5 eq '???' ? undef : $5,
			id_type  => $5 eq '???' ? undef : substr($5, 0, 1),
		};
	}

	my $root = {
		category => -d "$dir/{arch}" ? TREE : SOURCE,
		untagged => 0,
		type     => DIRECTORY,
		path     => '',
		id       => undef,
		id_type  => undef,
		children => _build_inv_tree(0, @inv_entries),
	};

	my $self = {
		directory => $dir,
		root      => $root,
	};

	return bless $self, $class;
}

sub directory ($) {
	my $self = shift;

	return $self->{directory};
}

sub get_root_entry ($) {
	my $self = shift;

	return $self->{root};
}

sub get_entry ($@) {
	my $self = shift;
	my @path = @_;

	@path = split /\//, $path[0]
		if @path == 1;

	my $entry = $self->get_root_entry;
	while (@path && defined $entry && ($entry->{type} eq DIRECTORY)) {
		$entry = $entry->{children}->{shift @path};
	}

	return @path ? undef : $entry;
}

sub get_listing ($) {
	my $self = shift;

	my $str;
	$self->foreach(sub {
		return unless $_[0]->{path};

		$str .= Arch::Inventory->to_string($_[0]);
		$str .= "\n";
	});

	return $str;
}

sub annotate_fs ($;$) {
	my $self = shift;

	if (@_) {
		$_[0]->{stat} = [ lstat("$self->{directory}/$_[0]->{path}") ];
		$_[0]->{symlink} = readlink("$self->{directory}/$_[0]->{path}")
			if $_[0]->{type} eq SYMLINK;
	} else {
		$self->foreach(sub { $self->annotate_fs($_[0]) });
	}
}

*annotate_stat = *annotate_fs; *annotate_fs = *annotate_fs;

sub foreach ($$) {
	my $self = shift;
	my $sub  = shift;
	my $root = shift || $self->get_root_entry;

	$sub->($root);

	if ($root->{type} eq DIRECTORY) {
		foreach my $child (sort keys %{$root->{children}}) {
			$self->foreach($sub, $root->{children}->{$child});
		}
	}
}

sub dump ($) {
	my $self = shift;

	require Data::Dumper;
	my $dumper = Data::Dumper->new([$self->get_root_entry]);
	$dumper->Sortkeys(1) if $dumper->can('Sortkeys');
	$dumper->Quotekeys(0);
	$dumper->Indent(1);
	$dumper->Terse(1);

	return $dumper->Dump;
}

sub to_string ($$) {
	my $class = shift;
	my $entry = shift;

	return sprintf("%s%s %s %s\t%s",
		$entry->{category},
		$entry->{untagged} ? '?' : ' ',
		$entry->{type},
		$entry->{path},
		$entry->{id} ? $entry->{id} : '???',
	);
}

# this assumes depth first ordering of @items
sub _build_inv_tree ($@) {
	my ($cut, @entries) = @_;

	my %toplevel = ();
	while (@entries) {
		my $child = shift @entries;
		my $name  = substr($child->{path}, $cut);

		die("invalid name $name; input not in correct order\n")
			if $name =~ m!/!;

		$toplevel{$name} = $child;
		next unless $child->{type} eq DIRECTORY;

		my $prefix = $child->{path} . '/';
		my $plen   = length($prefix);

		my @children = ();
		for (my $i = 0; $i < @entries;) {
			if ((length($entries[$i]->{path}) > $plen) &&
			    (substr($entries[$i]->{path}, 0, $plen) eq $prefix)) {
				push @children, splice @entries, $i, 1;
			} else {
				++$i;
			}
		}

		$child->{children} = &_build_inv_tree($plen, @children);
	}

	return \%toplevel;
}

1;

__END__