File Coverage

blib/lib/File/Pairtree.pm

Criterion	Covered	Total	%
statement	68	240	28.3
branch	8	134	5.9
condition	6	82	7.3
subroutine	14	27	51.8
pod	0	14	0.0
total	96	497	19.3

package File::Pairtree;

use 5.006;
use strict;
use warnings;

our $VERSION;
$VERSION = sprintf "%d.%02d", q$Name: Release-1-02 $ =~ /Release-(\d+)-(\d+)/;
#$VERSION = sprintf "%s", q$Name: Release-v0.304.0$ =~ /Release-(v\d+\.\d+\.\d+)/;
#our $NVERSION;			# pure numeric 2-part equivalent version
#($NVERSION = $VERSION) =~ s/v(\d+\.\d+)\.\d+/$1/;

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT = qw();
our @EXPORT_OK = qw(
	id2ppath ppath2id s2ppchars id2pairpath pairpath2id
	pt_lsid pt_lstree pt_mkid pt_mktree pt_rmid
	pt_budstr get_prefix
	$pfixtail
	$pair $pairp1 $pairm1
);
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);

our @EXPORT_FAIL = qw(
	pair=1 pair=2 pair=3 pair=4 pair=5 pair=6 pair=7 pair=8 pair=9
);
push @EXPORT_OK, @EXPORT_FAIL;		# add pseudo-symbols we will trap

# This is a magic routine that the Exporter calls for any unknown symbols.
# We use it to permit export of pseudo-symbols "pair=1", "pair=2", ...,
# "pair=9" so the caller can define a pair to mean 1, 2, ..., or 9 octets.
#
sub export_fail { my( $class, @symbols )=@_;

	my @unknowns;
	for (@symbols) {
		! s/^pair=([1-9])$/$1/ and
			push(@unknowns, $_),
			next;
		pair_means($_);		# define how many octets form a pair
	}
	return @unknowns;
}

# xxx Config?
my $default_pathcomp_sep = '/';

# In case we want to experiment with different cardinality of "pair",
# eg, 3 chars, 1 char, 4 chars.  This is mostly untested. XXX
#
our ($pair, $pairp1, $pairm1);

sub pair_means{ my( $n )=@_;

	die "the number meant by 'pair' must be a positive integer"
		if ($n < 1);
	$pair = $n;
	$pairp1 = $pair + 1;
	$pairm1 = $pair - 1;	# xxx what if $pairm1 is zero?
	return 1;
}
# XXXXXXXX arrange to call this at compile time?? punish the user if
#  they call it themselves???

# If not done so on import, define now how many octets in a pair.
#
defined($pair)		or pair_means(2);
#
# Now it's safe to define compiled regexps based on
# constant values for $pair, $pairp1, and $pairm1.

# this regexp matches a valid base ppath with bud attached
our $proper_ppath_re = "([^/]{$pair}/)*[^/]{1,$pair}";
our $root = "pairtree_root";

my $R = $root;
my $P = $proper_ppath_re;

# Pairtree - Pairtree support software (Perl module)
#
# Author:  John A. Kunze, [e-mail], California Digital Library, 2008
#          based on three lines of code originally from Sebastien Korner:
# $pt_objid =~ s/(\"|\*|\+|,|<|=|>|\?|\^|\|)/sprintf("^%x", ord($1))/eg;
# $pt_objid =~ tr/\/:./=+,/;
# my $pt_prefix = $namespace."/pairtree_root/".join('/', $pt_objid =~ /..|.$/g);

# id2ppath - return /-terminated ppath corresponding to id
#
# For Perl, the platform's path component separator ('/' or '\') is
# automagically converted when needed to do filesystem things; in fact,
# trying to use the correct separator can get you into trouble.  So we
# make it possible to specify the path component separator, but we won't
# do it for you.  Instead we assume '/'.
#
# The return path starts with /pairtree_root to encourage good habits --
# this could backfire.  We use the symbol 'pathcomp_sep' because
# 'path_sep' is already taken by the Config module to designate the
# character that separates entire pathnames, eg, ':' in the PATH
# environment variable.
#
# XXXXX this $pathcomp_sep -- is it worth a variable or is it better to
# let it be constant so we can compile the regexp?
sub id2ppath{ my( $id, $pathcomp_sep )=@_;	# single arg form, second
						# arg not advertized

	$pathcomp_sep ||= $default_pathcomp_sep;
#	$id =~ s{
#		(["*+,<=>?\\^|]			# some visible ASCII and
#		 |[^\x21-\x7e])			# all non-visible ASCII
#	}{
#		sprintf("^%02x", ord($1))	# replacement hex code
#	}xeg;
#
#	# Now do the single-char to single-char mapping.
#	# The / translated next is not to be confused with $pathcomp_sep.
#	#
#	$id =~ tr /\/:./=+,/;			# per spec, /:. become =+,

	$id = s2ppchars($id, $pathcomp_sep);

	return $root
		. $pathcomp_sep
		. join($pathcomp_sep, $id =~ /.{1,$pair}/g)
		. $pathcomp_sep;
		# . join($pathcomp_sep, $id =~ /..|.$/g)
}

sub s2ppchars{ my( $s, $pathcomp_sep )=@_;

	$pathcomp_sep ||= $default_pathcomp_sep;
	$s =~ s{
		(["*+,<=>?\\^|]			# some visible ASCII and
		 |[^\x21-\x7e])			# all non-visible ASCII
	}{
		sprintf("^%02x", ord($1))	# replacement hex code
	}xeg;

	# Now do the single-char to single-char mapping.
	# The / translated next is not to be confused with $pathcomp_sep.
	#
	$s =~ tr /\/:./=+,/;			# per spec, /:. become =+,
	return $s;
}

# XXX ditch 2-arg forms?
# This 2-arg form exists for parallelism with other language interfaces
# (that don't may not have optional arguments).  Perl users would
# normally prefer the id2ppath form for full functionality and speed.
#
sub id2pairpath{ my( $id, $pathcomp_sep )=@_;	# two-argument form

	return id2ppath($id, $pathcomp_sep);
}

# ppath2id - return id corresponding to ppath, or string of the form
#		"error: "
# There is more error checking required for ppath2id than id2ppath,
# as the domain is more constrained.
#
sub ppath2id{ my( $path, $pathcomp_sep )=@_;	# single arg form, second
						# arg not advertized
	my $id = $path;			# initialize $id with $path
	my $p = $pathcomp_sep || $default_pathcomp_sep;

	my $expect_hexenc;		# chars expected to be hex encoded
	if ($p eq '\\') {		# \ is a common, problemmatic case
		$expect_hexenc = '"*<>?|';	# don't need to encode \
		$p = '\\\\';		# and double escape for use in regex
	} else {
		$expect_hexenc = '"*<>?|\\\\';	# do need to encode \
	}

	# Trim everything from the beginning up to the last instance of
	# $root (via a greedy match).  If there's a pairpath to the right
	# of a given pairpath, assume that the most fine grained path
	# (rightmost) is the one the user's interested in.
	#
	$id =~ s/^.*$root//;

	# Normalize so there's no initial or final whitespace, no
	# repeated $pathcomp_sep chars, and exactly one $pathcomp_sep
	# at the beginning and end.
	#
	$id =~ s/^\s*/$p/;
	$id =~ s/\s*$/$p/;
	$id =~ s/$p+/$p/g;

	# Also trim any final junk, eg, anpath extension that is really
	# internal to an object directory.
	#
	$id =~ s/[^$p]{$pairp1,}.*$//;	# trim final junk

	# Finally, trim anything that follows a one-char path component,
	# a one-char component being another signal of the end of a ppath.
	# In a general sense, "one" here really means "one less than the
	# number of chars in a 'pair'".
	#
	$id =~ s/($p([^$p]){1,$pairm1}$p).*$/$1/;   # trim after 1-char comp.

	# Reject if there are any non-visible chars.
	#
	return "error: non-visible chars in $path" if
		$id =~ /[^\x21-\x7e]/;

	# Reject if there are any other chars that should be hex-encoded.
	#
	return "error: found chars expected to be hex-encoded in $path" if
		$id =~ /[$expect_hexenc]/;

	# Now remove the path component separators.
	#
	$id =~ s/$p//g;

	# Reverse the single-char to single-char mapping.
	# This might add formerly hex-encoded chars back in.
	#
	$id =~ tr /=+,/\/:./;		# per spec, =+, become /:.

	# Reject if there are any ^'s not followed by two hex digits.
	#
	return "error: impossible hex-encoding in $path" if
		$id =~ /\^($|.$|[^0-9a-fA-F].|.[^0-9a-fA-F])/;

	# Now reverse the hex conversion.
	#
	$id =~ s{
		\^([0-9a-fA-F]{2})
	}{
		chr(hex("0x"."$1"))
	}xeg;

	return $id;
}

use Carp;
use File::Spec;
use File::Find;
use File::Path;
use File::Namaste qw( nam_add );
use File::Value ':all';
use File::Glob ':glob';		# standard use of module, which we need
				# as vanilla glob won't match whitespace

our $Win;			# whether we're running on Windows
# xxx should probably test directly for symlink capacity
defined($Win) or	# if we're on a Windows platform avoid -l
	$Win = grep(/Win32|OS2/i, @File::Spec::ISA);

my $pfixtail = 'pairtree_prefix';

# Return empty string unless we find a prefix value.
sub get_prefix { my( $parent_dir )=@_;

	my $prefix = "";
	my $pxfile = $parent_dir . $pfixtail;
	return $prefix			unless -e $pxfile;
	my $msg = file_value("< $pxfile", $prefix);
	die "$pxfile: $msg"		if $msg;
	return $prefix;
}

# caller can define inputs $$r_opt{prefix} and $$r_opt{parent_dir} for speed
# we return under keys: msg, ppath, bud
# return 0 on success, 1 on soft fail, >1 on hard fail
# xxxxxxxxx get consistent on these return codes/croaks
#
sub pt_lsid { my( $dir, $id, $r_opt )=@_;

	$dir		or croak "no dir or empty dir";
	$id		or croak "no id or empty id";
	ref($r_opt) eq "HASH" or
		croak "r_opt must reference a hash (for input/output)";

	$dir = fiso_dname($dir, $R);	# make sure we have descender
	my $parent_dir = $$r_opt{parent_dir}
		|| fiso_uname($dir);
	my $prefix = $$r_opt{prefix}
		|| get_prefix($parent_dir);

	# prefix substitution is optional unless -f ??? XXXXX
	# xxx test
	$prefix and ! ($id =~ s/^$prefix//) and $$r_opt{force} and
		($$r_opt{msg} = "no prefix present in: $id"),
		return 2;

	my $ppath = $parent_dir . id2ppath($id);
	-e $ppath or
		($$r_opt{msg} = "non-existent ppath ($ppath)"),
		($$r_opt{ppath} = ""),
		return 1;		# softer failure than return 2
	$$r_opt{ppath} = $ppath;

	# Now that we have a valid ppath, we still don't know what
	# the encapsulating directory (or anything else for that
	# matter) looks like, so we use glob to look for things.
	# Recall that $ppath ends in a '/' (from id2ppath).
	# xxx sepchar better than / ?
	#
	my @buds = grep ! m{(^|/)\.\.?$},	# except for . and ..
		bsd_glob($ppath . "{*,.*}");	# look for all files
	my $nbuds = scalar @buds;		# how many buds?
	$nbuds == 0 and				# empty ppath, not a node
		($$r_opt{msg} = "no bud: $ppath"),
		($$r_opt{bud} = ""),
		return 2;

	# If we get here, there's one or more things at end of ppath.
	#
	$nbuds > 1 and
		($$r_opt{msg} = "expected one bud but got $nbuds buds"),
		($$r_opt{bud} = join " ", @buds),
		return 2;

	# If we get here, only one thing at end of ppath (the common case).
	#
	$$r_opt{bud} = shift @buds;

	# XXXXX  ??? $$r_opt{oxum},  $$r_opt{details} ?  $$r_opt{long}
	#        ? $$r_opt{all}
	return 0;
}

my $homily = "(pairpath end should be followed by only one thing -- " .
		"a directory name more than $pair characters long)";

# Create a closure to hold a stateful node-visiting subroutine and other
# options suitable to be passed as the options parameter to File::Find.
# Returns the small hash { 'wanted' => $visitor, 'follow' => 1 } and a
# subroutine $visit_over that can be called to summarize the visit.
#
sub make_visitor { my( $r_opt )=@_;

	my $om = $r_opt->{om} or
		return undef;

	my $objectcount = 0;		# number of objects encountered
	my $filecount = 0;		# number of files encountered xxx
	my $dircount = 0;		# number of directories encountered xxx
	my $symlinkcount = 0;		# number of symlinks encountered xxx
	my $irregularcount = 0;		# non file, non dir fs items to report

	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $sze);
	my ($pdname, $tpname, $wpname);
	my $symlinks_followed = 1;

	# yyy do as $curobj = {...}; ?
	my %curobj = (
		'ppath' => '',
		'encaperr' => 0,
		'octets' => 0,
		'streams' => 0,
	);

    # xxx move this outside closure and give it a $currobj arg?
    #     or is this much more efficient as-is?
    # xxx nail down everything that won't change during lstree
    my $newobj = sub { my( $ppath, $encaperr, $octets, $streams )=@_;

	# warning: ugly code ahead
	if ($curobj{'ppath'}) {		# print record of previous obj
		$_ = ppath2id($curobj{'ppath'});
		s/^/$r_opt->{prefix}/;		# uses global set in lstree()
		$r_opt->{long} and
			$om->elem('node',
				join("  ", $_, $curobj{'ppath'},
				"$curobj{'octets'}.$curobj{'streams'}")), 1
		or
			$om->elem('node', $_), 1
		;
		$curobj{'ppath'} eq $ppath and
			print "error: corrupted pairtree at pairpath ",
				"$ppath/: split end $homily\n";
		# xxx use om?
	}
	# xxx strange
	die "newobj: all args must be defined"
		unless (defined($ppath) && defined($encaperr)
			&& defined($octets) && defined($streams));
	$curobj{'ppath'} = $ppath;
	$curobj{'encaperr'} = $encaperr;
	$curobj{'octets'} = $octets;
	$curobj{'streams'} = $streams;
    };

    my $visitor = sub {		# receives no args from File::Find

	$pdname = $File::Find::dir;		# current parent directory name
	$tpname = $_;				# current filename in that dir
	$_ = $wpname = $File::Find::name;	# whole pathname to file

	# We always need lstat() info on the current node XXX why?
	# xxx tells us all, but if following symlinks the lstat is done
	# ... by find:  use (-X _), but of the nifty facts below we
	# still need to harvest the size ($sze) by hand.
	#
	($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $sze) = lstat($tpname)
		unless ($symlinks_followed and ($sze = -s _));

	#print "NEXT: $pdname $_ $wpname\n";

	# If we follow symlinks (usual), we have to expect the -l type,
	# which hides the type of the link target (what we really want).
	#
	if (! $Win and -l _) {
		$symlinkcount++;
		#print "XXXX SYMLINK $_\n";
		# yyy presumably this branch never happens when
		#     _not_ following links?
		($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $sze)
			= stat($tpname);	# get the real thing
	}
	# After this, tests of the form (-X _) give almost everything.

	if (-f $tpname) {
		$filecount++;
		if (m@^.*$R/(.*/)?pairtree.*$@o) {
			### print "$pdname PTREEFILE $tpname\n";
			# xxx    if $verbose;
			# else -prune ??
		}
		elsif (m@^.*$R/$P/[^/]+$@o) {
			#print "m@.*$R/$P/[^/]+@: $_\n";
		 	#print "$pdname UF $tpname\n";
			print "error: corrupted pairtree at pairpath ",
				"$pdname/: found unencapsulated file ",
				"'$tpname' $homily\n";
		}
		else {
			# xxx sanity check that $curobj is defined
			$curobj{'octets'} += $sze;
			### print "sssss $curobj{'octets'}\n";
			$curobj{'streams'}++;
		#	-fprintf $altout 'IN %p %s\n'
		#	$noprune
		}
	}
	elsif (-d $tpname) {
		$dircount++;
		if (m@^.*$R/(.*/)?pairtree.*$@o) {
			#print "$pdname PTREEDIR $tpname\n";
			# xxx if $verbose;
		#	-prune
		}
		# At last, we're entering a "regular" object.
		elsif (m@^.*$R/($P/)?[^/]{$pairp1,}$@o) {
			# start new object; but end previous object first
			# form: ppath, EncapErr, octets, streams
			$objectcount++;
			&$newobj($pdname, 0, 0, 0);
			# print "$pdname NS $tpname\n";
			#	-fprintf $altout 'START %h 0\n'
			#	$noprune
		}
		elsif (m@^.*$R/$P$@o) {
			#	-empty
			# xxx if $verbose...	-printf '%p EP -\n'
		}
		# $pair, $pairm1, $pairp1
		# We have a post-morty encapsulation error
		elsif (m@^.*$R/([^/]{$pair}/)*[^/]{1,$pairm1}/[^/]{1,$pair}$@o) {
			#print "$pdname PM $tpname\n";
			print "error: corrupted pairtree at pairpath ",
				"$pdname/: found '$tpname' after forced ",
				"path ending $homily\n";

			#	-fprintf $altout 'START %h 0\n'
			#	$noprune
		}
	}
	else {
		$irregularcount++;
	}
    };

    my $visit_over = sub { my( $ret, $tree )=@_;

	$ret ||= 0;

	# Dummy call to pt_newobj() to cough up the last buffered object.
	# xxx not multi-threadable!  how to give newobj its own context?
	&$newobj("", 0, 0, 0);			# shake out the last one

	# XXX what does find return?
	$om->elem("lstree", "find returned '$ret' for $tree")	if $ret;
	$om->elem("objectcount", "$objectcount object" .
		($objectcount == 1 ? "" : "s"));

	return ($objectcount);
    };

    	return ({ 'wanted' => $visitor, 'follow' => $r_opt->{follow_fast} },
		$visit_over);
}

sub pt_lstree { my( $tree, $r_opt, $r_visit_node, $r_wrapup )=@_;

	$tree		or croak "no tree dir or empty tree dir";
	ref($r_opt) eq "HASH" or
		croak "r_opt must reference a hash (for input/output)";
	ref( $r_visit_node ||= \&pt_visit_node ) eq "CODE" or
		croak "r_visit_node must reference a node-visiting function";
	#ref( $r_wrapup ||= \&pt_lstree_wrapup ) eq "CODE" or
	#	croak "r_wrapup must reference a node-visiting function";

	$tree = fiso_dname($tree, $R);	# make sure we have descender
	$$r_opt{parent_dir} ||= fiso_uname($tree);
	$$r_opt{prefix} ||= get_prefix($$r_opt{prefix});

	my ($find_opt, $visit_over) = make_visitor($r_opt);
	$find_opt or
		croak "make_visitor() failed";
	my $ret = find($find_opt, $tree);
	$visit_over and
		&$visit_over($ret, $tree);
	return $ret;
}

# Create the bud string that will encapsulate the leaf node
#
sub pt_budstr { my( $id, $bud_style )=@_;

	# Xxx add chars if less than $pair chars in $_
	$id ||= "";
	! $id and				# valid but empty id/ppath
		return "supernode";
	$bud_style ||= 0;			# xxx

	my $n = length($id) - 1;
	$n < $pair and				# pad on left with zeroes
		$id = ("0" x ($pair - $n)) . $id;

	# xxx optional variation on endings
	$bud_style == 0 and			# "full"
		return s2ppchars($id);
	#or			# XXX no other possibility right now
	;
	return s2ppchars($id);
}

sub pt_mkid { my( $dir, $id, $r_opt )=@_;

	$dir		or croak "no dir or empty dir";
	$id		or croak "no id or empty id";
	ref($r_opt) eq "HASH" or
		croak "r_opt must reference a hash (for input/output)";

	$dir = fiso_dname($dir, $R);	# make sure we have descender
	my $parent_dir = $$r_opt{parent_dir}
		|| fiso_uname($dir);
	my $prefix = $$r_opt{prefix}
		|| get_prefix($parent_dir);

	# prefix substitution is optional unless -f
	$prefix and ! ($id =~ s/^$prefix//) and $$r_opt{force} and
		($$r_opt{msg} = "no prefix present in: $id"),
		return 0;
	$id !~ m/^\s*$/ or		# double check that we won't xxx?
		croak "bad node";	# create a malformed pairtree

	-d $dir or			# need to create base directory
		pt_mktree($dir, "", $r_opt) and		# if error
		($$r_opt{msg} = "pt_mkid: $$r_opt{msg}"),
		return 1;		# return after adding our stamp
	my $ppath = $parent_dir . id2ppath($id);
	my $bud = $ppath . pt_budstr($id, $$r_opt{bud_style});

	my $ret;
	eval { $ret = mkpath($bud) };
	$@		and croak "Couldn't create $bud: $@";
	if ($ret == 0) {
		croak "pt_mkid: mkpath returned '0' for $bud"
			unless -e $bud;
		$$r_opt{msg} = "error: $bud ($id) already exists\n";
		return 0;
	}
	$$r_opt{ppath} = $ppath;
	$$r_opt{bud} = $bud;

	return 1;
}

sub pt_mktree { my( $dir, $prefix, $r_opt )=@_;

	# XXXX make up my mind about when to croak and when to
	#      use $$r_opt{msg}
	$dir		or croak "no tree dir or empty tree dir";
	$prefix ||= "";
	ref($r_opt) eq "HASH" or
		croak "r_opt must reference a hash (for input/output)";
			# except that we ignore any r_opt inputs here

	$dir = fiso_dname($dir, $R);	# make sure we have descender
	my $parent_dir = fiso_uname($dir);
	my $ret;
	eval { $ret = mkpath($dir) };
	if ($@) {
		$$r_opt{msg} = "Couldn't create $dir tree: $@";
		return 1;
	}
	if ($ret == 0) {
		$$r_opt{msg} = -e $dir ? "$dir already exists"
			: "pt_mktree: mkpath returned '0' for $dir";
		return 1;
	}

	my $pxfile = File::Spec->catfile($parent_dir, $pfixtail);
	my $msg = file_value("> $pxfile", $prefix)
		if ($prefix);
	if ($msg) {
		$$r_opt{msg} = "$pxfile: $msg";
		return 1;
	}
	$msg		and croak "Couldn't create namaste tag in $dir: $msg";
	$msg = nam_add($parent_dir, undef, '0', "pairtree_$VERSION", 0);
		# yyy better to use 0 to mean "don't truncate"
		#length("pairtree_$VERSION"));
	# xxxx croak or return via r_opt{msg}
	$msg	and croak "Couldn't create namaste tag in $parent_dir: $msg";

	return 0;
}

sub pt_rmid { my( $dir, $id, $r_opt )=@_;

	$dir		or croak "no dir or empty dir";
	$id		or croak "no id or empty id";
	ref($r_opt) eq "HASH" or
		croak "r_opt must reference a hash (for input/output)";

	$dir = fiso_dname($dir, $R);	# make sure we have descender
	my $parent_dir = $$r_opt{parent_dir}
		|| fiso_uname($dir);
	my $prefix = $$r_opt{prefix}
		|| get_prefix($parent_dir);

	# prefix substitution is optional unless -f
	$prefix and ! ($id =~ s/^$prefix//) and $$r_opt{force} and
		($$r_opt{msg} = "no prefix present in: $id"),
		return 0;
	$id !~ m/^\s*$/ or		# double check that we won't xxx?
		croak "bad node";	# create a malformed pairtree
#xxxxx this double check above should be against whole path
	## double check that we won't delete whole pairtree
	#die "bad node: $_"
	#	if m,$R/*$,;

	my $ppath = $parent_dir . id2ppath($id);
	-e $ppath or			# if it doesn't exist
		($$r_opt{msg} = "non-existent ppath ($ppath)"),
		($$r_opt{ppath} = ""),
		return 1;		# softer failure than return 2

	$$r_opt{ppath} = $ppath;
	my $ret;
	eval { $ret = rmtree($ppath) };
	if ($@) {
		$$r_opt{msg} = "Couldn't remove $ppath tree: $@";
		return 1;
	}
	if ($ret == 0) {
		$$r_opt{msg} = "warning: $id ($ppath) " .
			(-e $ppath ?  "not removed" : "doesn't exist");
		return 1;		# soft failure
	}
	return 0;			# success
}

1;

__END__