File Coverage

blib/lib/File/ANVL.pm

Criterion	Covered	Total	%
statement	181	274	66.0
branch	66	160	41.2
condition	25	120	20.8
subroutine	22	27	81.4
pod	0	17	0.0
total	294	598	49.1

package File::ANVL;

# XXXXXxxxx make adding a value policy-driven, eg,
# "add" could mean (a) replace, (b) push on end array,
# (c) push on start of array, (d) string concatenation,
# (d) error.

use 5.006;
use strict;
use warnings;

use constant NL		=> "\n";

# ANVL flavors
#
use constant ANVL	=> 1;
use constant ANVLR	=> 2;
use constant ANVLS	=> 3;

our $VERSION;
$VERSION = sprintf "%d.%02d", q$Name: Release-1-05 $ =~ /Release-(\d+)-(\d+)/;

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

our @EXPORT = qw();

our @EXPORT_OK = qw(
	anvl_recarray anvl_arrayhash
	anvl_name_naturalize
	anvl_rechash anvl_valsplit
	erc_anvl_expand_array kernel_labels
	xgetlines trimlines
	make_get_anvl
	anvl_opt_defaults anvl_decode anvl_om

	anvl_encode anvl_recsplit

	ANVL ANVLR ANVLS ANVLSH
);

our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);

# All these symbols must be listed also in EXPORT_OK (?)
#
our @EXPORT_FAIL = qw(
	ANVL ANVLR ANVLS ANVLSH
);

our $anvl_mode = 'ANVL';		# default mode

# This is a magic routine that the Exporter calls for any unknown symbols.
#
sub export_fail { my( $class, @symbols )=@_;

	$anvl_mode = $_		for (@symbols);
	return ();
}

# Initialize or re-initialize options to factory defaults.
#
sub anvl_opt_defaults { return {

	# Input options
	#
	autoindent	=> 1,	# yes, fix recoverably bad indention
	comments	=> 0,	# no, don't parse comments
	elemsproc	=>	# to expand short form ERCs (if any)
		\&File::ANVL::erc_anvl_expand_array,
	elemsprocpat	=>	# no call from anvl_om if no match
		qr/^erc:/m,	# in rec; no call if set and matches
	};
}

# xxx     decide on good name for short form and long form ERC

# Returns a closure that calls an input reader with that's set to *ARGV
# by default.  If $reader and $readee are defined, they are stored in the
# closure and all reads will be performed by calling &$reader($readee).
#
# The default reader collects text lines from a file and returns all the
# lines associated with the next "record", which is considered to start
# wherever the read pointer happens to be and continues to the first two
# blank lines encountered that occur after "substance" is detected.
# Substance is defined to be at least one non-whitespace character
# occurring on a non-comment line.  Comment and blank lines that precede
# a record with substance are returned, but any such lines that follow
# that the final record are discarded.
#
sub make_get_anvl { my( $reader, $readee ) = shift;

	unless ($reader) {

		my $rec;		# returned record
		my $s;			# next increment of input
		my $substance;		# boolean detecting substance

	    return sub { my( $filehandle ) = shift;

		# Returns a subroutine, call it get_anvl()
		#
		#   Usage:  $record = get_anvl( [$filehandle] );
		#
		# It reads ANVL input records as text lines from the
		# file given by $filehandle (*ARGV by default, which can
		# process multiple files via while loop magic).  Usually,
		# the closure holds enough state information, set up by
		# make_get_anvl(), that get_anvl() can be called without
		# arguments.  get_anvl() returns the record read as a
		# string, or returns undef on end of input or error.
		#
		$filehandle ||= *ARGV;
		local $/ = NL.NL;	# a kind of "paragraph" input mode
					# $/ === $INPUT_RECORD_SEPARATOR
		$rec = '';
		1 while (
			defined($s = <$filehandle>) and	# read to eof and
				($rec .= $s),	# save everything, but stop
				$substance =	# when we detect substance, ie,
					$s =~ /^[^#\s]/m || $s =~ /^[^#].*\S/m,
				! $substance	# non-comment with non-space
		);
		return $substance ?
			$rec :	# return either collected record or undef
			undef;	# any final blank or comment lines are tossed

		# yyy If more than one file, line numbers normally accumulate
		# across files.  Should we preserve line numbers within each
		# files?  (If so, use "close ARGV" (Perl idiom) to cause $.
		# (linenum) to be reset between files.
	    };
	}

	# If we get here, $reader should reference an input method and
	# $readee is assumed to be any value (eg, BDB handle) that may
	# permit &reader to get the next record.  Any other arguments
	# passed to the get_anvl() function below will be passed along
	# too, ie, $reader($readee, @_).
	#
	ref($reader) eq "CODE"		or return undef;

	my $rec;			# returned record
	my $s;				# next increment of input
	my $substance;			# boolean detecting substance

	return sub {
		$rec = '';
		1 while (
			# XXX should this accumulate in general??? or
			#     should we leave it to the definer of $reader?
			defined($s = &reader($readee, @_)) and	# read and
				($rec .= $s),	# save everything, but stop
				$substance =	# when we detect substance, ie,
					$s =~ /^[^#\s]/m || $s =~ /^[^#].*\S/m,
				! $substance	# non-comment with non-space
		);
		return $substance ?
			$rec :	# return either collected record or undef
			undef;	# any final blank or comment lines are tossed
	};
}

# XXX deprecated!  see sub make_get_anvl
sub xgetlines { my( $filehandle )=@_;

	my $rec = '';			# returned record
	my $s;				# next increment of input
	local $/ = NL.NL;		# a kind of "paragraph" input mode
					# $/ === $INPUT_RECORD_SEPARATOR

	# If $filehandle is specified, use the Perl <$filehandle> idiom to
	# return next unit of input (normally a line, but here a para).
	#
	$filehandle ||= *ARGV;
	1 while ( defined( $s = <$filehandle> ) and	# read up to two \n's

			# If we get here, $s now contains a block to save.
			#
			$rec .= $s,

			# We continue reading only if there's no substance,
			# ie, no line read starts with a non-comment and no
			# non-comment line read contains non-whitespace
			#
			#$s !~ /^[^#\s]/m and	# if no line read starts with
			#    $s !~ /^[^#].*\S/m	# or contains substance
			#(! ($s =~ /^[^#\s]/m || $s =~ /^[^#].*\S/m) and
			#	$rec .= "substance found in <$s>\n"),
			! ($s =~ /^[^#\s]/m || $s =~ /^[^#].*\S/m)
		);

			#$s !~ /^\s*[^#\s]/m ||	# match no line of susbstance
			#$rec .= $s

			#($rec .= $s),	# only "paragraphs"; save everything
			#$s !~ /^\s*[^#\s]/m	# but stop when substance seen

			#$s !~ /^\s*[^#\s]/m	# but stop when substance seen
			# and while $s matches no line starting with ^#
			# while every line in $s is either all whitespace
			#    or all comment (ie, first non-ws char is #)
			#$s =~ /\S/	# but stop when we see substance
			#$s !~ /\S/	# but stop when we see substance
# substance means \S on a non-comment line
#        $s !~ /^\S|[^#].*\S/m
# ! ($s =~ /^[^#\s]/m || $s =~ /^[^#].*\S/m)
			#
	#); # /^\s*[^#\s]/m
	defined($s) or
		return $rec || undef;	# almost eof or real eof
	return $rec;

	# XXXX what happens when one file ends prematurely and
	# another begins? does last record for first file get
	# returned glued to beginning of first recond of 2nd file?
	# If more than one file, line numbers normally just accumulate.
	# We want to preserve line numbers within files, so we use this
	# next Perl idiom to cause $. (linenum) to be reset between files.
	#
	#close ARGV	if eof;		# reset line numbers between files
}

# args: record, reference to whitespace lines, reference to real record lines
# xxx replace \n with NL throughout
# returns undef when $rec trims to nothing (EOF)
sub trimlines { my( $rec, $r_wslines, $r_rrlines )=@_;

	# $rec might legitimately be undefined if called as
	# trimlines(getlines(), ...)
	#
	$rec ||= '';

	$rec =~ s/^(\s*)//;		# '*' guarantees $1 will be defined
	my $blanksection = $1;
	my @newlines;

	ref($r_wslines) eq 'SCALAR' and		# if given, define it
		$$r_wslines = scalar(@newlines = $blanksection =~ /\n/g);

	ref($r_rrlines) eq 'SCALAR' and		# if given, define it
		$$r_rrlines = scalar(@newlines = $rec =~ /\n/g);

	#$$r_rrlines = scalar($rec =~ /$/gm);	# xxx why doesn't this work?

	# At this point $r_wslines and $r_rrlines (if supplied) are safely
	# defined and ready for return.
	#
	$rec or			# empty record (but $r_wslines may be defined)
		return undef;	# signal eof-style return

	#$rec =~ /\n\n$/ and		# ok record ending -- this is
	#	return $rec;		# the usual  return
	#$rec =~ s/\n*$/\n\n/;		# normalize premature eof ending
	return $rec;
}

# returns empty string on success or string beginning "warning:..."
# third arg (0 or 1) optional
# elems is returned array of name value pairs
#DEPRECATED:
sub anvl_recsplit { my( $record, $r_elems, $strict )=@_;

	! defined($record) and
		return "needs an ANVL record";
	ref($r_elems) ne "ARRAY" and
		return "2nd arg must reference an array";

	my $strict_default = 0;
	! defined($strict) and
		$strict = $strict_default;

	local $_ = $record;
	s/^\s*//; s/\s*$//;		# trim both ends
	/\n$/	or s/$/\n/;		# normalize end of record to \n

	/\n\n/ and
		return "record should have no internal blank line(s)";
	# xxx adjust regexp for ANVLR
	! /^[^\s:][\w 	]*:/ and	# match against first element
		return "well-formed record begins with a label and colon";

	$anvl_mode ne ANVLR and
		s/^#.*\n//gm;		# remove comments plus final \n

	# If we're not in strict parse mode, correct for common error
	# where continued value is not indented.  We can pretty safely
	# assume a continued value if a line is flush left and contains
	# no colon at all.
	#
	# This next substitution match needs to be multi-line to avoid
	# more explicit looping.
	#
	# XXX there's probably a more efficient way to do this.
	my $msg = "";
	my $indented = s/^([^\s:][^:]*)$/ $1/gm;
	if ($indented) {
		$strict and
			(@$r_elems = undef),
			return "error: $indented unindented value line(s)";
		$msg = "warning: indenting $indented value line(s)";
	}
	# if we get here, assume standard continuation lines, and join them
	# (GRANVL style)
	#
	s/\n\s+/ /g;
	# XXX should have a newline-preserving form of parse?

	# Split into array element pairs.  Toss first "false" split.
	# xxx buggy limited patterns, how not to match newline

	# This is the critical splitting step.
	# splits line beginning  ..... xxx
	#
	s/\n$//;			# strip final \n
	(undef, @$r_elems) = split /\n*^([^\s:][\w 	]*):\s*/m;

	return $msg;
}

# xxxxxxxx respond to 'comments' (def. off), 'autoindent' (def. on),
#   'anvlr' (def. off), 'granvl' ?

# This is the closest thing to a reference implementation of an ANVL
# record parser.
# It returns "" on success, or "error: ..." or "warning: ..."

sub anvl_recarray { my( $record, $r_elems, $linenum, $o )=@_;

	! defined($record) and
		return "error: no input record";
	ref($r_elems) ne "ARRAY" and
		return "error: 2nd arg must reference an array";

	# Note: this input $linenum is pure digits, while $lineno on
	# output is a combination of digits and type (':' or '#')
	#
	defined($linenum)	or $linenum = 1;
	$linenum =~ /\D/ and
		return "error: 3rd arg ($linenum) must be a positive integer";
# XXX can't this be optimized a bit to keep defaults around?
	$o ||= anvl_opt_defaults();
	ref($o) ne "HASH" and
		return "error: 4th arg must reference a hash";

	local $_ = $record;	# localizing $_ prevents modifying global $_

	s/^\s*//; s/\s*$//;		# trim both ends
	/\n$/	or s/$/\n/;		# normalize end of record to \n
	#s/\n?$/\nEOR:/;	# whether record ends in \n or not, normalize
	#		# end of record to \nEOR: (note no \n after \nEOR:)

	# Reject some malformed cases.
	#
	#/\n\n/ and
	#	return "error: record should have no internal blank line(s)";
	# xxx adjust regexp for ANVLR
# XXX fix so record can consist of nothing but comments and/or whitespace;
#     comments _may_ be recognized in regular records, but not in this kind
	#/^[^\s:][\w 	]*:/m or	# match against first element
	#	return "error: record ($_) should begin with a label and colon";

	# Any other unindented line not containing a colon will either
	# cause an error or will be automatically indented.

	# xxx what about $anvl_mode ne ANVLR and??

	# Now we synthesize stuff (line numbers and pseudo-element names for
	# any comments) in order to create a uniform structure on each line,
	# so that we can finally call 'split' to bust apart that structure
	# into a Perl array in which every 3-element group corresponds to
	#     1. a line number,
	#     2. a label, and
	#     3. a value.
	#
	# First insert a line number and ":" in front of each line.
	#
	my $num = $linenum;
	s/^/ $num++ . ":" /gem;	# put a line number on each line

	# Remove blank lines, now that line numbers have been preserved.
	#
	s/^\d+:[^\S\n]*\n//gm;

	# Now, if we're not deleting comments, insert a pseudo-element
	# name '#:' in front of each comment while also changing the ':'
	# after the line numer to '#'.  This means that all lines will
	# begin with a line number followed by ':' for real elements or
	# by '#' for comment elements.  Eg, '# foo' on line 3 becomes
	# '3##:# foo', which conforms to the eventual split pattern we
	# rely on (at end).
	#
# xxx problem with line #K:value, which becomes, eg, 4##:K:value
	$$o{comments} and		# if we're keeping comments
		s/^(\d+):#/$1##:/gm, 1
	                #    ^^^
	                #    123
			# 1=separator, 2=pseudo-name,
			# 3=original value minus '#' starts after :

	or				# else completely delete comments
		s/^\d+:#.*\n//gm	# up to and including final \n
	;

	# Return if nothing's left after deleting blank lines and comments.
	#
	/^\s*$/s and
		return "warning: record at line $linenum has no content";

	my $msg = "";			# default return message

	# If we're not in strict parse mode, correct for common error
	# where continued value is not indented.  We can pretty safely
	# assume a continued value if a line is flush left and contains
	# no colon at all.
	#
	# This next substitution match is multi-line to avoid explicit
	# looping (yyy is this an efficient way to do it?).  It indents
	# by one space any line starting without a space or colon and
	# that has no instance of a colon until end of line.
	#
	my $indented = s/^(\d+:)([^\s:][^:]*)$/$1 $2/gm;
	if ($indented) {
		unless ($$o{autoindent}) {
			@$r_elems = undef;	# XXXXX isn't this too much?
			return "error: $indented unindented value line(s)";
		}
		$msg = "warning: indenting $indented value line(s)";
	}

	# Now we join the (normalized) continuation lines (GRANVL style)
	# so each element-value pair is on one line.  The + in [ \t]+ is
	# very important; we can't use \s+ here because \s matches a \n.
	#
	s/\n\d+:[ \t]+/ /g;
	#s/\n\d+:\s+/ /g;
	# XXX should we have a newline-preserving form of parse?

	# Get rid of initial whitespace from all non-comment GRANVL values.
	s/^(\d+:[^\s:][^:]*:)[ \t]+/$1/gm;
# xxx problem with line #K:value, which becomes, eg, 4##:K:value

	# Split into array of element pairs.  Toss first "false" split.
	# xxx buggy limited patterns, how not to match newline

	# This is the critical splitting step.
	# splits line beginning  ..... xxx
	#
	s/\n$//;			# strip final \n
	@$r_elems = ('', 'ANVL',	# 3rd elem of 1st triple is
		# provided by first element resulting from the split

		split /\n*^(\d+[:#])([^\s:][^:]*):/m

# xxx problem with line #K:value, which becomes, eg, 4##:K:value
	);

	defined($$r_elems[2]) or
		return "error: split failed ($_) on '$record', " .
			"record at line $linenum";

	# If there was a value with no label at the start of the record,
	# we deem that interesting enough to keep even though it's not
	# ANVL-compliant; the caller can prevent this by turning off
	# 'autoindent', the processing for which will either flag this as
	# an error or will have inserted one space in front of the value.
	#
	$$r_elems[2] =~ /^(\d+): (.*)/ and
		($$r_elems[0], $$r_elems[2]) = ($1, $2);

	#(undef, @$r_elems) = split /\n*^([^\s:][\w 	]*):\s*/m;
	# yyy an approach once considered but not used
	# $num = $.;	# linenum
	# s/^/ $num++ . ":" /e	while (/\n/g);
	# /\G  ($N\#.*\n)+  (?=$N[^\#]) /gx	# comment block
	# /\G  ($N\S.*\n)+  (?=$N[^\S]) /gx	# element on one or more lines
	# /\G  (#.*\n)+(?=[^#])/g
	# /^#.*?\n[^#]/s        # (?=lookahead)
	#return "_=$_\n" . join(", ", @$r_elems);	# to check results

	return $msg;
}

# XXXXXX for consolidating a:b and a:c into a:b;c, MAJOR constraint
#        is that b and c CANNOT contain '|' or we refuse...

sub anvl_arrayhash { my( $r_elems, $r_hash, $first_only )=@_;

	ref($r_elems) ne "ARRAY" and
		return "error: 1st arg must reference an array";
	ref($r_hash) ne "HASH" and
		return "error: 2nd arg must reference a hash";
	defined($first_only)	or $first_only = 0;

	my $num_elems = scalar @$r_elems;
	$num_elems % 3 != 0 and
		return "error: input array length must be a multiple of 3";

	$num_elems < 1		and return "";	# no elements, we're done

	my $msg = '';			# xxx needed?
	my ($name, $value, $n, $v);

	# We know there must be at least 3 elements, so it's safe to check
	# the special first triple (index 2 is the only one we look at now)
	# for an initial unlabeled record element (non-standard ANVL).
	# If we find something, we make up the name, '_'.
	#
	if ($$r_elems[2]) {		# first triple is special
		$name = '_';
		! defined $$r_hash{$name} and
			$$r_hash{$name} = [ 0 ]		# initialize array
		or
			push @{ $$r_hash{$name} }, 0	# add to array
	}

	for ($n = 3; $n < $num_elems; $n += 3) {

		$name = $$r_elems[$n + 1];
		! defined $$r_hash{$name} and
			$$r_hash{$name} = [ $n ]	# initialize array
		or
			push @{ $$r_hash{$name} }, $n	# add to array
		;
	}
	return $msg;
}

# ANVL value split
# xxx rename to anvl_valarray?
# returns empty string on success or string beginning "warning:..."
# r_svals is reference to an array that will be filled upon return
sub anvl_valsplit { my( $value, $r_svals )=@_;

	! defined($value) and
		return "needs an ANVL value";
	ref($r_svals) ne "ARRAY" and
		return "2nd arg must reference an array";
	local $_;

	#xxx print "r_svals=$r_svals\n";
	#xxx print "value=$value\n";
	my $warning = "";		# xxx used?
	#my $ret_subvalues = \$_[1];

	# Assume value is all on one line and split it.
	#my @svals = split /\|/, $value;
	@$r_svals = split /\|/, $value;
	#$_[1] = \@svals;
	$_ = [ split(/;/, $_) ]		# create array of arrays
		for (@$r_svals);
		#xxxprint("svals=", join(", ", @$_), "\n")	for (@$r_svals);

	# xxxx need to look for all 3 levels:  (change spec)
	# XXXXXXX  value ::= one or more svals (sval1 | sval2 | ...)
	# XXXXXXX  sval ::= one or more rvals (rval1 ; rval2 ; ...)
	# XXXXXXX  rval ::= one or more qvals (qval1 (=) qval2 (=) ...)
	#   where s=sub, r=repeated, q=equivalent
	# XXXXXXX  or ?? rval ::= one or more avals (aval1 (=) aval2 (=) ...)
	return $warning ? "warning: $warning" : "";
}

# Create record hash, elem is key, value is value
#
sub anvl_rechash { my( $record, $r_hash, $strict )=@_;

	! defined($record) and
		return "needs an ANVL record";
	ref($r_hash) ne "HASH" and
		return "2nd arg must reference a hash";

	my $msg = "";
	my @elems;
	($msg = anvl_recsplit($record, \@elems, $strict)) and
		return "anvl_recsplit: $msg";

	my ($name, $value);
	while (1) {
		$name = shift @elems;
		last	unless defined $name; 	# nothing left
		$value = shift @elems;
		if (! defined $$r_hash{$name}) {
			# Nothing there, so store scalar and continue.
			$$r_hash{$name} = $value;	# 1st value (non-array)
			next;
		}
		# If we get here there's something's already there.
		# Don't overwrite if we're in $strict mode.
		# xxx document this
		#
		$strict		and next;	# don't overwrite

		# XXXXXxxxx make adding a value policy-driven, eg,
		# "add" could mean (a) replace, (b) push on end array,
		# (c) push on start of array, (d) string concatenation,
		# (d) error.
		# xxx should anvl_rechash save line numbers?
		# xxx should anvl_recsplit save line numbers?

		# Whatever is there could be a scalar or an array reference.
		# If not a reference, create an anonymous array, put a
		# scalar into it, and refer to the array.
		#
		my $v = $$r_hash{$name};	# add to current
		$v = [ $v ]		# make an array if currently
			unless ref $v;	# there's only one value

		# If we get here, we have a reference to an array,
		# possibly empty.  Either way, we can push onto it.
		#
		push @$v, $value;
	}
	return $msg;
}

# [ !"#\$%&'\(\)\*\+,/:;<=>\?@\[\\\]\|\0]
our %anvl_decoding = (

	'sp'  =>  ' ',		# decodes to space (0x20)
	'ex'  =>  '!',		# decodes to ! (0x21)
	'dq'  =>  '"',		# decodes to " (0x22)
	'ns'  =>  '#',		# decodes to # (0x23)
	'do'  =>  '$',		# decodes to $ (0x24)
	'pe'  =>  '%',		# decodes to % (0x25)
	'am'  =>  '&',		# decodes to & (0x26)
	'sq'  =>  "'",		# decodes to ' (0x27)
	'op'  =>  '(',		# decodes to ( (0x28)
	'cp'  =>  ')',		# decodes to ) (0x29)
	'as'  =>  '*',		# decodes to * (0x2a)
	'pl'  =>  '+',		# decodes to + (0x2b)
	'co'  =>  ',',		# decodes to , (0x2c)
	'sl'  =>  '/',		# decodes to / (0x2f)
	'cn'  =>  ':',		# decodes to : (0x3a)
	'sc'  =>  ';',		# decodes to ; (0x3b)
	'lt'  =>  '<',		# decodes to < (0x3c)
	'eq'  =>  '=',		# decodes to = (0x3d)
	'gt'  =>  '>',		# decodes to > (0x3e)
	'qu'  =>  '?',		# decodes to ? (0x3f)
	'at'  =>  '@',		# decodes to @ (0x40)
	'ox'  =>  '[',		# decodes to [ (0x5b)
	'ls'  =>  '\\',		# decodes to \ (0x5c)
	'cx'  =>  ']',		# decodes to ] (0x5d)
	'vb'  =>  '|',		# decodes to | (0x7c)
	'nu'  =>  "\0",		# decodes to null (0x00)
);
# XXXXXXX need way to encode newlines (using '\n' in interim)

our %anvl_encoding;

#%cn :
#%sc ;

# xxxxx handle these separately
#	# XXXX remove %% from erc/anvlspec?
#	'%'   =>  '%pe',	# decodes to % (0x25)  xxxx do this first?
#	'_'   =>  '',		# a non-character used as a syntax shim
#	'{'   =>  '',		# a non-character that begins an expansion block
#	'}'   =>  '',		# a non-character that ends an expansion block

# Takes a single arg.
sub anvl_decode {

	local $_ = shift(@_) || '';

	pos() = 0;			# reset \G for $_ just to be safe
	while (/(?=\%\{)/g) {		# lookahead; \G matches just before
		my $p = pos();		# note \G position before it changes
		s/\G \%\{ (.*?) \%\}//xs	# 's' modifier makes . match \n
			or last;	# if no closing brace, skip match
		my $exp_block = $1;	# save removed expansion block
		$exp_block =~ s/\s+//g;	# strip it of all whitespace
		pos() = $p;		# revert \G to where we started and
		s/\G/$exp_block/;	# re-insert changed expansion block
	}
	s/\%[}{]//g;			# remove any remaining unmatched
	s/\%_//g;			# xxx %_ -> ''
	s/\%\%/\%pe/g;			# xxx ??? xxxx???
	# decode %XY where XY together don't form a valid pair of hex digits
	s/\%([g-z][a-z]|[a-z][g-z])/$anvl_decoding{$1}/g;
	return $_;
}

# xxx encoding should be context-sensitive, eg, name, value
sub anvl_encode { my( $s )=@_;

	# XXXX just define this in the module??
	unless (%anvl_encoding) {	# one-time definition
		# This just defines an inverse mapping so we can encode.
		$anvl_encoding{$anvl_decoding{$_}} = $_
			for (keys %anvl_decoding);
	}
	$s =~
	  s/([ !\"#\$\%&'\(\)\*\+,\/:;<=>\?@\[\\\]\|\0])/\%$anvl_encoding{$1}/g;
	return $s;
}

# return $name in natural word order, using ANVL inversion points
# repeat for each final comma present
sub anvl_name_naturalize { my( $name )=@_;

	$name ||= '';
	$name =~ /^\s*$/	and return $name;	# empty

	# "McCartney, Paul, Sir,,"
	# a, b, c, d, e,,, -> e d c a, b
	my $prefix = '';
	while ($name =~ s/,\s*$//) {
		$name =~ s/^(.*),\s*([^,]+)(,*$)/$1$3/ and
			$prefix .= $2 . ' ';
	}
	return $prefix . $name;
}

sub anvl_summarize { my( @nodes )=@_; }

# XXXXX doesn't this really belong in an ERC.pm module?
#
# ordered list of kernel element names
our @kernel_labels = qw(
	who
	what
	when
	where
	how
	why
	huh
);
#
# This routine inspects and possibly modifies in place the kind of element
# array resulting from a call to anvl_recarray(), which splits and ANVL
# record.  It is useful for transforming short form ERC elements into full
# form elements, for example, to expand "erc:a|b|c|d" into the equivalent,
# "erc:\nwho:a\nwhat:b\nwhen:c\nwhere:d".
# It returns the empty string on success, otherwise an error message.
#
sub erc_anvl_expand_array { my( $r_elems )=@_;

	use File::ANVL;
	my ($lineno, $name, $value, $msg, @svals, $sval);
	my $me = 'erc_anvl_expand_array';
	my $i = 3;		# skip first 3 elems (anvl array preamble)
 	while (1) {
		$lineno = $$r_elems[$i++];
		$name = $$r_elems[$i++] || '';
		$value = $$r_elems[$i++] || '';
		last	unless defined $lineno;	# end of record
 		next			# skip unless we have erc-type thing
			if ($name ne 'erc' || $value =~ /^\s*$/);
			#if ($name !~ /^erc\b/ || $value =~ /^\s*$/);
			# xxx should do this for full generality

		# If here, we have an erc-type thing with a non-empty value.
		#
		($msg = anvl_valsplit($value, \@svals)) and
			return "error: $me: anvl_valsplit: $msg";

		# XXXX only doing straight "erc" (eg, not erc-about)
		my $j = 0;
		my @extras = ();
		# If we exceed known labels, we'll re-use last known label.
		my $unknown = $kernel_labels[$#kernel_labels];
		foreach $sval (@svals) {

			# xxx not (yet) tranferring subvalue structure
			#     to anvl_om or other conversion
			# Recall that each $sval is itself a reference to
			# an array of subvalues (often just one element).
			#
			push @extras,		# trust kernel_labels order
				$lineno,
				$kernel_labels[$j++] || $unknown,
				join('; ',	# trim ends of subvalues
					map(m/^\s*(.*?)\s*$/, @$sval)
				);
		}
		# Finally, replace our $value element with '' and append
		# the new extra values we've just expanded.
		splice @$r_elems, $i-1, 1,
			'',		# replaces $value we just used up
			@extras;	# adds new elements from $value
 	}
	return '';			# success
}

# XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX=============
# xxx checkm _in_   obj1 obj2 ...  --> returns noids
# xxx checkm _out_  id1 id2 ...  --> returns objects

# XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX=============
# xxx do metadata scan of object before ingest and confirm with user that
# the object is correctly identified.  This could even be done remotely.
# Start with informal staff service for depositing objects, returning a
# short url to a stable object, and not clogging up allstaff inboxes with
# huge attachments.  Also applies to any number of draft docs for review
# but in temporary storage (but stable).

# XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX=============
# xxx do id generator service with 'expiring' ids.  To mint, you tell us
# who you are first.  To get a perm. id, you agree to use your minted id
# and bind it within N months.  We track, and warn you several times
# until N months as elapsed and then reclaim/recycle the id.

############################################
# Output Multiplexer routines
############################################

#    #$erc = "erc: Smith, J.|The Whole Truth|2004|http://example.com/foo/bar";
#    $errmsg = File::ERC::erc_anvl2erc_turtle ($erc, $rec);
#    $errmsg and
#	print("$errmsg\n")
#    or
#	print("turtle record:\n$rec\n")
#    ;

# xxx anvl_fmt not consistent with om_anvl!

# Input file(s) from ARGV.

sub anvl_om { my( $om, $o, $get_anvl )		= (shift, shift, shift);

	return "anvl_om: 1st arg not an OM object"
		if ref($om) !~ /^File::OM::/;
	my $p = $om->{outhandle};	# whether 'print' status or small
	$o ||= anvl_opt_defaults();
	$get_anvl ||= File::ANVL::make_get_anvl();	# xxx set input here?
# XXX test return value!

	my $s = '';			# output strings are returned to $s
	my $st = $p ? 1 : '';		# returns (stati or strings) accumulate
	my ($msg, $allmsgs, $anvlrec, $lineno, $name, $value, $pat, $n, $nmax);
	my (%rechash, $ne, $nemax, $elem_name);	# for alt. element ordering
	my $r_elem_order = $$o{elem_order};

	$s = $om->ostream();		# open stream

	# This next line is a fast and compact (if cryptic) way to
	# accumulate $om->method calls.  Used after each method call, it
	# concatenates strings or ANDs up print statuses, depending on the
	# outhandle setting.  It makes several appearances in this routine.
	#
	$p and ($st &&= $s), 1 or ($st .= $s);	# accumulate method returns

	# Numbers: record, element in record, and start line
	#
	my ($startline, $recnum, $elemnum) = (1, 0, 0);
	my ($wslines, $rrlines);
	my $r_elems = $om->{elemsref};		# abbreviation
	# xxx is that reference kosher?

	while (1) {

		# Get an ANVL record and count lines therein.  ANVL
		# records can come from anywhere, but typically from
		# a file (read in "paragraph" mode) or a BDB database.
		#
		$anvlrec = trimlines(&$get_anvl(), \$wslines, \$rrlines);
		$startline += $wslines;
		last		unless $anvlrec;

		$recnum++;		# increment record counter
=for later
# XXX anvl_recarray is expensive, do we _need_ to do it if the output is
#     also in anvl?  Maybe call modified [2] here so "find" can work?
		if (ref($om) eq 'File::OM::ANVL' and ! $r_elem_order) {
			# xxx do quick expand (short->long erc) here?
			#     xxx _will_ disturb input line numbering
			$$o{find} and ($anvlrec !~ /$$o{find}/m) and
				next;		# no output has occurred
			# xxx do quick check for 'show' and next
			# XXXXXXXX must define lineno for verbose case
			$s = $om->anvl_rec($anvlrec, $startline, $rrlines);
			$p and ($st &&= $s), 1 or ($st .= $s);
			next;
		}
=cut
		$msg = anvl_recarray($anvlrec, $r_elems, $startline, $o);
		$msg =~ /^error/	and return "anvl_recarray: $msg";
		$msg eq "" or
			#print $msg, "\n";
			#$o->{verbose} && print $msg, "\n";
			$allmsgs .= $msg . "\n";	# save other message

		# NB: apply 'find' here before possible expansion, which
		# means that a pattern like "who:\s*smith" won't work on
		# on a short form ANVL record.
		#
		$$o{find} and ($anvlrec !~ /$$o{find}/m) and
			next;		# no output has occurred

		# If caller has set $$o{elemsproc} to a code reference,
		# it is called to process the element array just returned
		# from anvl_recarray.  Typically this is used to convert
		# (with erc_anvl_expand_array) short form ERCs to long
		# form ERCs.  As an optimization, the code is not called
		# if $$o{elemsprocpat} (typically, "erc") is set and
		# doesn't match the raw record string.
		#
		if (ref($$o{elemsproc}) eq "CODE" and	# if code and either
			(! ($pat = $$o{elemsprocpat}))	# no pattern or
				|| $anvlrec =~ $pat) {	# the pattern matches

# [2] XXX can we call elemsproc directly on the $anvlrec? so we don't need
#     to call expensive anvl_recarray first?
			($msg = &{$$o{elemsproc}}($r_elems)) and
				return "File::ANVL::elemsproc: $msg";
		}
		ref($om) eq 'File::OM::Turtle' and
			turtle_set_subject($om, $anvlrec);

		# The orec method is given first crack at a new record.
		# It sets and/or clears a number of values for keys (eg,
		# for turtle, $$o{subject}).  $recnum is useful for
		# outputting json separators (eg, no comma if $recnum eq 1)
		# or record numbers in comments (eg, if $$o{verbose}).
		# $startline is useful for parser diagnostics (eg, "error
		# on line 5").  $r_elems and $r_elem_order are needed for
		# discovering what elements will populate CSV/PSV records.
		#
# XXX this next isn't needed if output is anvl ?!  (assuming final NL is
# written when closing the record
		$s = $om->orec($recnum, $startline, $r_elems, $r_elem_order);
		$p and ($st &&= $s), 1 or ($st .= $s);

		if ($r_elem_order) {
			undef %rechash;		# don't want prior indices
			($msg = anvl_arrayhash($r_elems, \%rechash)) and
				return "anvl_arrayhash: $msg";
			$ne = -1;		# index into $$r_elem_order
			$nemax = scalar @$r_elem_order;
		} else {
			$n = 			# index into $$r_elems
# XXX don't reference r_elems if we haven't called anvl_recarray
				$$r_elems[2]	# if a no-label value starts
					? -3	# rec, make sure to output it,
					: 0;	# else skip it (normal)
			$nmax = scalar @$r_elems;
		}

# XXX if output is to anvl, can we not skip the entire loop below? but
# not if it's possible to output anvl _and_ to care about element order
# XXX but still perform $show check and skip not-shown elems
# XXX and still perform value inversion if {invert} options
		$elemnum = 0;			# true elements, not comments
		undef $name;
		while (1) {

			# Select next candidate element.  If we need to
			# output elements in a certain order, consult the
			# hash; otherwise, just use "found" order.
			#
			if ($r_elem_order) {	# use specified order

				$ne++;
				$ne >= $nemax		and last;

				# For CSV and PSV, the element name at this
				# position may be deliberately undefined, or
				# may correspond to a named element missing
				# in this record, in which case we skip it.
				#
				$elem_name = $r_elem_order->[$ne];
				! defined($elem_name) || ! defined(
					#XXX ignore multiple instances for now
					$n = $rechash{$elem_name}->[0]
				    ) and
					# for CSV/PSV, output an empty element
					next;

			} else {		# use natural array order
				$n += 3;
				$n >= $nmax		and last;
			}
			# If we get here, $n is defined.

			$lineno = $$r_elems[$n];
			$name = $n < 3		# for special first triple
				? '_'		# use synthesized name '_'
				: $$r_elems[$n + 1];	# else real name
			$value = $$r_elems[$n + 2] || "";

			$elemnum++		unless $name eq '#';

			# Skip if 'show' given and not requested.
			$$o{show} and ("$name: $value" !~ /$$o{show}/m) and
				(undef $name),	# cause elem to be skipped
				next;

			# Instead of $om->oelem, $om->celem, $om->contelem,
			# combine open and close into one, but first
			# naturalize values if called upon.
			#
			$$o{invert} and $value =~ /,\s*$/ and
				$value = anvl_name_naturalize($value);
		}
		continue {
			$s = $om->elem($name, $value, $lineno);
			$p and ($st &&= $s), 1 or ($st .= $s);
			undef $name;		# clean the slate
		}
		$s = $om->crec($recnum);
		$p and ($st &&= $s), 1 or ($st .= $s);
	}
	continue {
		$startline += $rrlines;
	}
	# XXX currently doing nothing with $allmsgs warnings!
	#     should probably print if verbose mode on
	$s = $om->cstream();
	$p and ($st &&= $s), 1 or ($st .= $s);

	return $st;
}

# xxx document all om options
# xxx should om also have a recstring slot (for anvlrec)?
# xxx pass in turtle_nosubject (default)?
sub turtle_set_subject {

	my ($om, $anvlrec) = (shift, shift);
	my $r_elems = $om->{elemsref};

	# In order to find the subject element for Turtle/RDF
	# assertions, we need an element name pattern.  If one is
	# defined in $om->{turtle_subjelpat}, use it.  If it's undefined,
	# per-record code will use 'where' if it thinks the record
	# is an ERC, or use 'identifier|subject' as a last resort.
	# If no element matching subjelpat is found, $om->{subject}
	# will default to $om->{turtle_nosubject}.
	#
	my $subjpat = $om->{turtle_subjelpat} ||
		($anvlrec =~ /^erc\s*:/m
			? "^where\$" :	# 1st where in an 'erc', or
		($anvlrec =~ /^(identifier|subject)\s*:/m
			? "^$1\$" :	# 1st identifier or subject,
		($anvlrec =~ /^(.+)\s*:\s*(\n\s+)*\w/
			? "^$1\$" :	# or 1st non-empty element
		'')));			# or nothing (always matches)

	# Now find a 'subject' for our Turtle/RDF assertions.
	#
	my $j = 1;	# element names in positions 1, 4, 7, ...
	1 while ($j < $#$r_elems and			# quickly find it
		@$r_elems[$j] !~ $subjpat and ($j += 3));
	$om->{subject} = $j < $#$r_elems && $subjpat ?	# if found,
			@$r_elems[$j + 1] :		# use associated value
			$om->{turtle_nosubject};	# else use default
	return $om->{subject};
}

1;

__END__