File Coverage

blib/lib/Noid.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package Noid;

use 5.000000;
use strict;
use warnings;

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

our $VERSION;
$VERSION = sprintf "%d.%02d", q$Name: Release-0-424 $ =~ /Release-(\d+)-(\d+)/;
our @EXPORT_OK = qw(
	addmsg bind checkchar dbopen dbclose dbcreate dbinfo
	errmsg fetch getnoid hold hold_release hold_set
	locktest logmsg mint n2xdig note parse_template queue
	sample scope validate VERSION xdig
);

# Noid - Nice opaque identifiers (Perl module)
#
# Author:  John A. Kunze, [e-mail], California Digital Library
#		Originally created, UCSF/CKM, November 2002
#
# ---------
# Copyright (c) 2002-2006 UC Regents
#
# Permission to use, copy, modify, distribute, and sell this software and
# its documentation for any purpose is hereby granted without fee, provided
# that (i) the above copyright notices and this permission notice appear in
# all copies of the software and related documentation, and (ii) the names
# of the UC Regents and the University of California are not used in any
# advertising or publicity relating to the software without the specific,
# prior written permission of the University of California.
#
# THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
# EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
# WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
#
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE FOR ANY
# SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
# OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
# WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY
# THEORY OF LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE
# OR PERFORMANCE OF THIS SOFTWARE.
# ---------

# Perl style note -- this code makes frequent use of a fast, big boolean
# version of an if-elsif-else idiom that Perl encourages because entering
# a { block } is relatively expensive, but it looks strange if you're not
# used to it.  Instead of
#
#	if ( e1 && e2 && e3 ) {
#		s1;
#		s2;
#		...;
#	}
#	elsif ( e4 || e5 && e6 ) {
#		s3;
#	}
#	else {
#		s4;
#		s5;
#	}
#
# we can write this series of test expressions and statements as
#
#	e1 && e2 && e3 and
#		s1,
#		s2,
#	1 or
#	e4 || e5 && e6 and
#		s3,
#	1 or
#		s4,
#		s5,
#	1;
#
# If we KNOW (not safest) that s2 and s3 are "true", we shorten it to
#
#	e1 && e2 && e3 and
#		s1,
#		s2
#	or
#	e4 || e5 && e6 and
#		s3
#	or
#		s4,
#		s5
#	;
#
# For the big boolean form to work, you'll be well-advised to call make
# your Perl calls with the parenthesized syntax, so that the commas
# terminating the boolean statements don't get swallowed up by the Perl
# functions and built-ins that you're using (eg, can get into trouble
# unless you parenthesize your "print" statements).

# yyy many comment blocks are very out of date -- need thorough review
# yyy make it so that http://uclibs.org/PID/foo maps to
#     ark.cdlib.org/ark:/13030/xzfoo  [ requirement from SCP meeting May 2004]
# yyy use "wantarray" function to return either number or message
#     when bailing out.
# yyy add cdlpid doc to pod ?
# yyy write about comparison with PURLs
# yyy check chars, authentication, ordinal stored in metadata
# yyy implement mod 4/8/16 distribution within large counter regions?
# yyy implement count-down counters as well as count-up?
# yyy make a shadow DB

# yyy upgrade ark-service and ERC.pm (which still use PDB.pm)

# yyy bindallow(), binddeny() ????

use constant NOLIMIT		=> -1;
use constant SEQNUM_MIN		=>  1;
use constant SEQNUM_MAX		=>  1000000;

# The database must hold nearly arbitrary user-level identifiers
# alongside various admin variables.  In order not to conflict, we
# require all admin variables to start with ":/", eg, ":/oacounter".
# We use "$R/" frequently as our "reserved root" prefix.
#
my $R = ":";		# prefix for global top level of admin db variables

use Fcntl qw(:DEFAULT :flock);
use BerkeleyDB;

# Global %opendbtab is a hash that maps a hashref (as key) to a database
# reference.  At a minimum, we need opendbtab so that we avoid passing a
# db reference to dbclose, which cannot do the final "untie" (see
# "untie gotcha" documentation) while the caller's db reference is
# still defined.
#
my %opendbtab;

# To iterate over all Noids in the database, use
#
# each %hash
# return $db or null
# $flags one of O_RDONLY, O_RDWR, O_CREAT

our ($legalstring, $alphacount, $digitcount);
our $locktest = 0;

# Adds an error message for a database pointer/object.  If the message
# pertains to a failed open, the pointer is null, in which case the
# message gets saved to what essentially acts like a global (possible
# threading conflict).
#
sub addmsg{ my( $noid, $message )=@_;

	$noid ||= "";		# act like a global in case $noid undefined
	$opendbtab{"msg/$noid"} .= $message . "\n";
	return 1;
}

# Returns accumulated messages for a database pointer/object.  If the
# second argument is non-zero, also reset the message to the empty string.
#
sub errmsg{ my( $noid, $reset )=@_;

	$noid ||= "";		# act like a global in case $noid undefined
	my $s = $opendbtab{"msg/$noid"};
	$reset and
		$opendbtab{"msg/$noid"} = "";
	return $s;
}

sub logmsg{ my( $noid, $message )=@_;

	$noid ||= "";		# act like a global in case $noid undefined
	my $logfhandle = $opendbtab{"log/$noid"};
	defined($logfhandle) and
		print($logfhandle $message, "\n");
	# yyy file was opened for append -- hopefully that means always
	#     append even if others have appended to it since our last append;
	#     possible sync problems...
	return 1;
}

sub storefile { my( $fname, $contents )=@_;
	! open(OUT, ">$fname") and
		return 0;
	print OUT $contents;
	close(OUT);
	return 1;
}

# Legal values of $how for the bind function.
#
my @valid_hows = qw(
	new replace set
	append prepend add insert
	delete purge mint peppermint
);

#
# --- begin alphabetic listing (with a few exceptions) of functions ---
#

# Returns ANVL message on success, undef on error.
#
sub bind { my( $noid, $contact, $validate, $how, $id, $elem, $value )=@_;
# yyy to add: incr, decr for $how;  possibly other ops (* + - / **)

	# Validate identifier and element if necessary.
	#
	# yyy to do: check $elem against controlled vocab
	#     (for errors more than for security)
	# yyy should this genonly setting be so capable of contradicting
	#     the $validate arg?
	$$noid{"$R/genonly"} && $validate
		&& ! validate($noid, "-", $id) and
			return(undef)
	or
	! defined($id) || $id eq "" and
		addmsg($noid, "error: bind needs an identifier specified."),
		return(undef)
	;
	! defined($elem) || $elem eq "" and
		addmsg($noid, qq@error: "bind $how" requires an element name.@),
		return(undef);

	# Transform and place a "hold" (if "long" term and we're not deleting)
	# on a special identifier.  Right now that means a user-entrered Id
	# of the form :idmap/Idpattern.  In this case, change it to a database
	# Id of the form "$R/idmap/$elem", and change $elem to hold Idpattern;
	# this makes lookup faster and easier.
	#
	# First save original id and element names in $oid and $oelem to
	# use for all user messages; we use whatever is in $id and $elem
	# for actual database operations.
	#
	my ($oid, $oelem, $hold) = ($id, $elem, 0);
	if ($id =~ /^:/) {
		$id !~ m|^:idmap/(.+)| and
			addmsg($noid, qq@error: $oid: id cannot begin with ":"@
				. qq@ unless of the form ":idmap/Idpattern".@),
			return(undef);
		($id, $elem) = ("$R/idmap/$oelem", $1);
		$$noid{"$R/longterm"} and
			$hold = 1;
	}
	# yyy transform other ids beginning with ":"?

	# Check circulation status.  Error if term is "long" and the id
	# hasn't been issued unless a hold was placed on it.
	#
	# If no circ record and no hold...
	if (! defined($$noid{"$id\t$R/c"}) && ! exists($$noid{"$id\t$R/h"})) {
		$$noid{"$R/longterm"} and
			addmsg($noid, "error: "
				. qq@$oid: "long" term disallows binding @
				. "an unissued identifier unless a hold is "
				. "first placed on it."),
			return(undef)
		or
			logmsg($noid, "warning:"
				. " $oid: binding an unissued identifier"
				. " that has no hold placed on it.")
		;
	}
	if (grep(/^$how$/, @valid_hows) != 1) {
		addmsg($noid, "error: bind how?  What does $how mean?");
		return(undef);
	}
	my $peppermint = ($how eq "peppermint");
	$peppermint and
		# yyy to do
		addmsg($noid, qq@error: bind "peppermint" not implemented.@),
		return(undef);
	# YYY bind mint file Elem Value		-- put into FILE by itself
	# YYY bind mint stuff_into_big_file Elem Value -- cat into file
	if ($how eq "mint" || $how eq "peppermint") {
		$id ne "new" and
			addmsg(qq@error: bind "mint" requires id to be @
				. qq@given as "new".@),
			return(undef);
		! ($id = $oid = mint($noid, $contact, $peppermint)) and
			return(undef);
	}
	$how eq "delete" || $how eq "purge" and
		(defined($value) && $value eq "" and
			addmsg($noid, qq@error: why does "bind $how" @
				. "have a supplied value ($value)?"),
			return(undef)),
		$value = "",
		1
	or
	! defined($value) and
		addmsg($noid,
			qq@error: "bind $how $elem" requires a value to bind.@),
		return(undef)
	;
	# If we get here, $value is defined and we can use with impunity.

	dblock();
	if (! defined($$noid{"$id\t$elem"})) {		# currently unbound
		grep(/^$how$/, qw( replace append prepend delete )) == 1 and
			addmsg($noid, qq@error: for "bind $how", "$oid $oelem" @
				. "must already be bound."),
			dbunlock(),
			return(undef);
		$$noid{"$id\t$elem"} = "";	# can concatenate with impunity
	}
	else {						# currently bound
		grep(/^$how$/, qw( new mint peppermint )) == 1 and
			addmsg($noid, qq@error: for "bind $how", "$oid $oelem" @
				. " cannot already be bound."),
			dbunlock(),
			return(undef);
	}
	# We don't care about bound/unbound for:  set, add, insert, purge

	my $oldlen = length($$noid{"$id\t$elem"});
	my $newlen = length($value);
	my $statmsg = "$newlen bytes written";

	$how eq "delete" || $how eq "purge" and
		delete($$noid{"$id\t$elem"}),
		$statmsg = "$oldlen bytes removed"
	or
	$how eq "add" || $how eq "append" and
		$$noid{"$id\t$elem"} .= $value,
		$statmsg .= " to the end of $oldlen bytes",
	or
	$how eq "insert" || $how eq "prepend" and
		$$noid{"$id\t$elem"} = $value . $$noid{"$id\t$elem"},
		$statmsg .= " to the beginning of $oldlen bytes",
	or
		$$noid{"$id\t$elem"} = $value,
		$statmsg .= ", replacing $oldlen bytes",
	;
	$hold and exists($$noid{"$id\t$elem"}) and ! hold_set($noid, $id) and
		$hold = -1;	# don't just bail out -- we need to unlock

	# yyy $contact info ?  mainly for "long" term identifiers?
	dbunlock();

	return(
# yyy should this $id be or not be $oid???
# yyy should labels for Id and Element be lowercased???
"Id:      $id
Element: $elem
Bind:    $how
Status:  " . ($hold == -1 ? errmsg($noid) : "ok, $statmsg") . "\n");
}

# Primes:
#   2        3        5        7
#  11       13       17       19
#  23       29       31       37
#  41       43       47       53
#  59       61       67       71
#  73       79       83       89
#  97      101      103      107
# 109      113      127      131
# 137      139      149      151
# 157      163      167      173
# 179      181      191      193
# 197      199      211      223
# 227      229      233      239
# 241      251      257      263
# 269      271      277      281
# 283      293      307      311
# 313      317      331      337
# 347      349      353      359
# 367      373      379      383
# 389      397      401      409
# 419      421      431      433
# 439      443      449      457
# 461      463      467      479
# 487      491      499      503  ...

# yyy other character subsets? eg, 0-9, a-z, and _  (37 chars, with 37 prime)
#      this could be mask character 'w' ?
# yyy there are 94 printable ASCII characters, with nearest lower prime = 89
#      a radix of 89 would result in a huge, compact space with check chars
#      mask character 'c' ?

# Extended digits array.  Maps ordinal value to ASCII character.
my @xdig = (
	'0', '1', '2', '3', '4',   '5', '6', '7', '8', '9',
	'b', 'c', 'd', 'f', 'g',   'h', 'j', 'k', 'm', 'n',
	'p', 'q', 'r', 's', 't',   'v', 'w', 'x', 'z'
);
# $legalstring should be 0123456789bcdfghjkmnpqrstvwxz
$legalstring = join('', @xdig);
$alphacount = scalar(@xdig);		# extended digits count
$digitcount = 10;			# pure digit count

# Ordinal value hash for extended digits.  Maps ASCII characters to ordinals.
my %ordxdig = (
	'0' =>  0,  '1' =>  1,  '2' =>  2,  '3' =>  3,  '4' =>  4,
	'5' =>  5,  '6' =>  6,  '7' =>  7,  '8' =>  8,  '9' =>  9,

	'b' => 10,  'c' => 11,  'd' => 12,  'f' => 13,  'g' => 14,
	'h' => 15,  'j' => 16,  'k' => 17,  'm' => 18,  'n' => 19,

	'p' => 20,  'q' => 21,  'r' => 22,  's' => 23,  't' => 24,
	'v' => 25,  'w' => 26,  'x' => 27,  'z' => 28
);

# Compute check character for given identifier.  If identifier ends in '+'
# (plus), replace it with a check character computed from the preceding chars,
# and return the modified identifier.  If not, isolate the last char and
# compute a check character using the preceding chars; return the original
# identifier if the computed char matches the isolated char, or undef if not.

# User explanation:  check digits help systems to catch transcription
# errors that users might not be aware of upon retrieval; while users
# often have other knowledge with which to determine that the wrong
# retrieval occurred, this error is sometimes not readily apparent.
# Check digits reduce the chances of this kind of error.
# yyy ask Steve Silberstein (of III) about check digits?

sub checkchar{ my( $id )=@_;
	return undef
		if (! $id );
	my $lastchar = chop($id);
	my $pos = 1;
	my $sum = 0;
	my $c;
	for $c (split(//, $id)) {
		# if character undefined, it's ordinal value is zero
		$sum += $pos * (defined($ordxdig{"$c"}) ? $ordxdig{"$c"} : 0);
		$pos++;
	}
	my $checkchar = $xdig[$sum % $alphacount];
	#print "RADIX=$alphacount, mod=", $sum % $alphacount, "\n";
	return $id . $checkchar
		if ($lastchar eq "+" || $lastchar eq $checkchar);
	return undef;		# must be request to check, but failed match
	# xxx test if check char changes on permutations
	# XXX include test of length to make sure < than 29 (R) chars long
	# yyy will this work for doi/handles?
}

# Returns an array of cleared ids and byte counts if $verbose is set,
# otherwise returns an empty array.  Set $verbose when we want to report what
# was cleared.  Admin bindings aren't touched; they must be cleared manually.
#
# We always check for bindings before issuing, because even a previously
# unissued id may have been bound (unusual for many minter situations).
#
# Use dblock() before and dbunlock() after calling this routine.
#
sub clear_bindings { my( $noid, $id, $verbose )=@_;

	my @retvals;
	my $db = $opendbtab{"bdb/$noid"};
	my $cursor = $db->db_cursor();

	# yyy right now "$id\t" defines how we bind stuff to an id, but in the
	#     future that could change.  in particular we don't bind (now)
	#     anything to just "$id" (without a tab after it)
	my ($first, $skip, $done) = ("$id\t", 0, 0);
	my ($key, $value) = ($first, 0);
	my $status = $cursor->c_get($key, $value, DB_SET_RANGE);
	$status == 0 and
		$skip = ($key =~ m|^$first$R/|),
		$done = ($key !~ m|^$first|),
	1 or
		$done = 1
	;
	while (! $done) {
		! $skip and $verbose and
			# if $verbose (ie, fetch), include label and
			# remember to strip "Id\t" from front of $key
			push(@retvals, ($key =~ /^[^\t]*\t(.*)/ ? $1 : $key)
				. ": clearing " . length($value) . " bytes"),
			delete($$noid{$key});
		$status = $cursor->c_get($key, $value, DB_NEXT);
		$status != 0 || $key !~ /^$first/ and
			$done = 1	# no more elements under id
		or
			$skip = ($key =~ m|^$first$R/|)
		;
	}
	undef($cursor);
	return($verbose ? @retvals : ());
}

# Returns a short printable message on success, undef on error.
#
sub dbcreate { my( $dbdir, $contact, $template, $term,
		$naan, $naa, $subnaa )=@_;

	my ($total, $noid);
	my $dir = "$dbdir/NOID";
	my $dbname = "$dir/noid.bdb";
	# yyy try to use "die" to communicate to caller (graceful?)
	# yyy how come tie doesn't complain if it exists already?

	-e $dbname and
		addmsg(undef, "error: a NOID database already exists in "
			. ($dbdir ne "." ? "\"$dbdir\"."
				: "the current directory.") . "\n"
			. "\tTo permit creation of a new minter, rename\n"
			. "\tor remove the entire NOID subdirectory."),
		return(undef);
	! -d $dir && ! mkdir($dir) and
		addmsg(undef, "error: couldn't create database directory\n"
			. "$dir: $!\n"),
		return(undef);

	my ($prefix, $mask, $gen_type, $msg, $genonly);
	! defined($template) and
		$genonly = 0,
		$template = ".zd"
	or
		$genonly = 1,			# not generated ids only
	;
	$total = parse_template($template, $prefix, $mask, $gen_type, $msg);
	! $total and
		addmsg($noid, $msg),
		return(undef);
	my $synonym = "noid" . ($genonly ? "_$msg" : "any");

	# Type check various parameters.
	#
	! defined($contact) || $contact !~ /\S/ and
		addmsg($noid, "error: contact ($contact) must be non-empty."),
		return(undef);

	$term ||= "-";
	$term ne "long" && $term ne "medium"
			&& $term ne "-" && $term ne "short" and
		addmsg($noid, "error: term ($term) must be either "
			. qq@"long", "medium", "-", or "short".@),
		return(undef);

	! defined($naa) and $naa = "";
	! defined($naan) and $naan = "";
	! defined($subnaa) and $subnaa = "";

	$term eq "long" &&
		($naan !~ /\S/ || $naa !~ /\S/ || $subnaa !~ /\S/) and
			addmsg($noid, qq@error: longterm identifiers require @
				. "an NAA Number, NAA, and SubNAA."),
			return(undef);
	# xxx should be able to check naa and naan live against registry
	# yyy code should invite to apply for NAAN by email to [e-mail]
	# yyy ARK only? why not DOI/handle?
	$term eq "long" && ($naan !~ /\d\d\d\d\d/) and
		addmsg($noid, qq@error: term of "long" requires a @
			. "5-digit NAAN (00000 if none), and non-empty "
			. "string values for NAA and SubNAA."),
		return(undef);

	# Create log and logbdb files from scratch and make them writable
	# before calling dbopen().
	#
	! storefile("$dir/log", "") || ! chmod(0666, "$dir/log") and
		addmsg(undef, "Couldn't chmod log file: $!"),
		return(undef);
	! storefile("$dir/logbdb", "") || ! chmod(0666, "$dir/logbdb") and
		addmsg(undef, "Couldn't chmod logbdb file: $!"),
		return(undef);
	! ($noid = dbopen($dbname, DB_CREATE)) and
		addmsg(undef, "can't create database file: $!"),
		return(undef);
	logmsg($noid, ($template ?
		qq@Creating database for template "$template".@
		: "Creating database for bind-only minter."));

	# Database info
	# yyy should be using db-> ops directly (for efficiency and?)
	#     so we can use DB_DUP flag
	$$noid{"$R/naa"} = $naa;
	$$noid{"$R/naan"} = $naan;
	$$noid{"$R/subnaa"} = $subnaa || "";

	$$noid{"$R/longterm"} = ($term eq "long");
	$$noid{"$R/wrap"} = ($term eq "short");		# yyy follow through

	$$noid{"$R/template"} = $template;
	$$noid{"$R/prefix"} = $prefix;
	$$noid{"$R/mask"} = $mask;
	$$noid{"$R/firstpart"} = ($naan ? $naan . "/" : "") . $prefix;
	$$noid{"$R/addcheckchar"} = ($mask =~ /k$/);	# boolean answer

	$$noid{"$R/generator_type"} = $gen_type;
	$$noid{"$R/genonly"} = $genonly;

	$$noid{"$R/total"} = $total;
	$$noid{"$R/padwidth"} = ($total == NOLIMIT ? 16 : 2) + length($mask);
		# yyy kludge -- padwidth of 16 enough for most lvf sorting

	# Some variables:
	#   oacounter	overall counter's current value (last value minted)
	#   oatop	overall counter's greatest possible value of counter
	#   held	total with "hold" placed
	#   queued	total currently in the queue
	$$noid{"$R/oacounter"} = 0;
	$$noid{"$R/oatop"} = $total;
	$$noid{"$R/held"} = 0;
	$$noid{"$R/queued"} = 0;

	$$noid{"$R/fseqnum"} = SEQNUM_MIN;	# see queue() and mint()
	$$noid{"$R/gseqnum"} = SEQNUM_MIN;	# see queue()
	$$noid{"$R/gseqnum_date"} = 0;		# see queue()

	$$noid{"$R/version"} = $VERSION;

	# yyy should verify that a given NAAN and NAA are registered,
	#     and should offer to register them if not.... ?

	# Capture the properties of this minter.
	#
	# There are seven properties, represented by a string of seven
	# capital letters or a hyphen if the property does not apply.
	# The maximal string is GRANITE (we first had GRANT, then GARNET).
	# We don't allow 'l' as an extended digit (good for minimizing
	# visual transcriptions errors), but we don't get a chance to brag
	# about that here.
	#
	# Note that on the Mohs mineral hardness scale from 1 - 10,
	# the hardest is diamonds (which are forever), but granites
	# (combinations of feldspar and quartz) are 5.5 to 7 in hardness.
	# From http://geology.about.com/library/bl/blmohsscale.htm ; see also
	# http://www.mineraltown.com/infocoleccionar/mohs_scale_of_hardness.htm
	#
	# These are far from perfect measures of identifier durability,
	# and of course they are only from the assigner's point of view.
	# For example, an alphabetical restriction doesn't guarantee
	# opaqueness, but it indicates that semantics will be limited.
	#
	# yyy document that (I)mpressionable has to do with printing, does
	#     not apply to general URLs, but does apply to phone numbers and
	#     ISBNs and ISSNs
	# yyy document that the opaqueness test is English-centric -- these
	#     measures work to some extent in English, but not in Welsh(?)
	#     or "l33t"
	# yyy document that the properties are numerous enough to look for
	#     a compact acronym, that the choice of acronym is sort of
	#     arbitrary, so (GRANITE) was chosen since it's easy to remember
	#
	# $pre and $msk are in service of the letter "A" below.
	(my $pre = $prefix) =~ s/[a-z]/e/ig;
	(my $msk = $mask) =~ s/k/e/g;
	$msk =~ s/^ze/zeeee/;		# initial 'e' can become many later on

	my $properties =
		($naan ne "" && $naan ne "00000" ? "G" : "-")
		. ($gen_type eq "random" ? "R" : "-")
		# yyy substr is supposed to cut off first char
		. ($genonly && ($pre . substr($msk, 1)) !~ /eee/ ? "A" : "-")
		. ($term eq "long" ? "N" : "-")
		. ($genonly && $prefix !~ /-/ ? "I" : "-")
		. ($$noid{"$R/addcheckchar"} ? "T" : "-")
		# yyy "E" mask test anticipates future extensions to alphabets
		. ($genonly && ($prefix =~ /[aeiouy]/i || $mask =~ /[^rszdek]/)
			? "-" : "E")		# Elided vowels or not
	;
	$$noid{"$R/properties"} = $properties;

	# Now figure out "where" element.
	#
	use Sys::Hostname;
	my $host = hostname();

#	my $child_process_id;
#	unless (defined($child_process_id = open(CHILD, "-|"))) {
#		die "unable to start child process, $!, stopped";
#		}
#	if ($child_process_id == 0) {
#		# We are in the child.  Set the PATH environment variable.
#		$ENV{"PATH"} = "/bin:/usr/bin";
#		# Run the command we want, with its STDOUT redirected
#		# to the pipe that goes back to the parent.
#		exec "/bin/hostname";
#		die "unable to execute \"/bin/hostname\", $!, stopped";
#	}
#	else {
#		# We are in the parent, and the CHILD file handle is
#		# the read end of the pipe that has its write end as
#		# STDOUT of the child.
#		$host = ;
#		close(CHILD);
#		chomp $host;
#	}

	my $cwd = $dbdir;	# by default, assuming $dbdir is absolute path
	if ($dbdir !~ m|^/|) {
		$cwd = $ENV{"PWD"} . "/$dbdir";
		}

	# Adjust some empty values for short-term display purposes.
	#
	$naa ||= "no Name Assigning Authority";
	$subnaa ||= "no sub authority";
	$naan ||= "no NAA Number";

	# Create a human- and machine-readable report.
	#
	my @p = split(//, $properties);			# split into letters
	s/-/_ not/ || s/./_____/
		for (@p);
	my $random_sample;			# undefined on purpose
	$total == NOLIMIT and
		$random_sample = int(rand(10));	# first sample less than 10
	my $sample1 = sample($noid, $random_sample);
	$total == NOLIMIT and
		$random_sample = int(rand(100000));	# second sample bigger
	my $sample2 = sample($noid, $random_sample);

	my $htotal = ($total == NOLIMIT ? "unlimited" : human_num($total));
	my $what = ($total == NOLIMIT ? "unlimited" : $total)
		. qq@ $gen_type identifiers of form $template
       A Noid minting and binding database has been created that will bind
       @
		. ($genonly ? "" : "any identifier ") . "and mint "
		. ($total == NOLIMIT ? qq@an unbounded number of identifiers
       with the template "$template".@
		: $htotal . qq@ identifiers with the template "$template".@)
		. qq@
       Sample identifiers would be "$sample1" and "$sample2".
       Minting order is $gen_type.@;

	$$noid{"$R/erc"} =
qq@# Creation record for the identifier generator in NOID/noid.bdb.
#
erc:
who:       $contact
what:      $what
when:      @ . temper() . qq@
where:     $host:$cwd
Version:   Noid $VERSION
Size:      @ . ($total == NOLIMIT ? "unlimited" : $total) . qq@
Template:  @ . (! $template ? "(:none)" : $template . qq@
       A suggested parent directory for this template is "$synonym".  Note:
       separate minters need separate directories, and templates can suggest
       short names; e.g., the template "xz.redek" suggests the parent directory
       "noid_xz4" since identifiers are "xz" followed by 4 characters.@) . qq@
Policy:    (:$properties)
       This minter's durability summary is (maximum possible being "GRANITE")
         "$properties", which breaks down, property by property, as follows.
          ^^^^^^^
          |||||||_$p[6] (E)lided of vowels to avoid creating words by accident
          ||||||_$p[5] (T)ranscription safe due to a generated check character
          |||||_$p[4] (I)mpression safe from ignorable typesetter-added hyphens
          ||||_$p[3] (N)on-reassignable in life of Name Assigning Authority
          |||_$p[2] (A)lphabetic-run-limited to pairs to avoid acronyms
          ||_$p[1] (R)andomly sequenced to avoid series semantics
          |_$p[0] (G)lobally unique within a registered namespace (currently
                     tests only ARK namespaces; apply for one at ark@
	     . '@' . [e-mail])
Authority: $naa | $subnaa
NAAN:      $naan
@;
	! storefile("$dir/README", $$noid{"$R/erc"})
		and return(undef);
	# yyy useful for quick info on a minter from just doing 'ls NOID'??
	#          storefile("$dir/T=$prefix.$mask", "foo\n");

	my $report = qq@Created:   minter for $what  @
		. qq@See $dir/README for details.\n@;

	! $template and
		dbclose($noid),
		return($report);

	init_counters($noid);
	dbclose($noid);
	return($report);
}

# Report values according to $level.  Values of $level:
# "brief" (default)	user vals and interesting admin vals
# "full"		user vals and all admin vals
# "dump"		all vals, including all identifier bindings
#
sub dbinfo { my( $noid, $level )=@_;
	my $db = $opendbtab{"bdb/$noid"};
	my $cursor = $db->db_cursor();
	my ($key, $value) = ("$R/", 0);
	if ($level eq "dump") {
		print "$key: $value\n"
			while ($cursor->c_get($key, $value, DB_NEXT) == 0);
		return 1;
	}
	my $status = $cursor->c_get($key, $value, DB_SET_RANGE);
	if ($status) {
		addmsg($noid, "c_get status/errno ($status/$!)");
		return 0;
	}
	if ($key =~ m|^$R/$R/|) {
		print "User Assigned Values\n";
		print "  $key: $value\n";
		while ($cursor->c_get($key, $value, DB_NEXT) == 0) {
			last
				if ($key !~ m|^$R/$R/|);
			print "  $key: $value\n";
		}
		print "\n";
	}
	print "Admin Values\n";
	print "  $key: $value\n";
	while ($cursor->c_get($key, $value, DB_NEXT) == 0) {
		last
			if ($key !~ m|^$R/|);
		print "  $key: $value\n"
			if ($level eq "full" or
				$key !~ m|^$R/c\d| &&
				$key !~ m|^$R/saclist| &&
				$key !~ m|^$R/recycle/|);
	}
	print "\n";
	undef $cursor;
	return 1;
}

# yyy eventually we would like to do fancy fine-grained locking with
#     BerkeleyDB features.  For now, lock before tie(), unlock after untie().
sub dblock{ return 1;	# placeholder
}
sub dbunlock{ return 1;	# placeholder
}

# returns noid: a listref
# $flags can be DB_RDONLY, DB_CREATE, or 0 (for read/write, the default)
#
sub dbopen { my( $dbname, $flags )=@_;

	# yyy to test: can we now open more than one noid at once?

	my ($env, $envhome);
	($envhome = $dbname) =~ s|[^/]+$||;	# path ending in "NOID/"
	! -d $envhome and
		addmsg(undef, "$envhome not a directory"),
		return undef;
	# yyy probably these envflags are overkill right now
	my $envflags = DB_INIT_LOCK | DB_INIT_TXN | DB_INIT_MPOOL;
	#my $envflags = DB_INIT_CDB | DB_INIT_MPOOL;
	($flags & DB_CREATE) and
		$envflags |= DB_CREATE;
	my @envargs = (
		-Home => $envhome,
		-Flags => $envflags,
		-Verbose => 1
	);

	# If it exists and is writable, use log file to inscribe BDB errors.
	#
	my ($logfile, $logfhandle, $log_opened, $logbdb);

	$logfile = $envhome . "log";
	$log_opened = open($logfhandle, ">>$logfile");
	$logbdb = $envhome . "logbdb";
	-w $logbdb and
		push(@envargs, ( -ErrFile => $logbdb ));
	# yyy should we complain if can't open log file?

	$env = new BerkeleyDB::Env @envargs;
	! defined($env) and
		addmsg(undef, "no \"Env\" object ($BerkeleyDB::Error)"),
		return undef;

#=for deleting
#
#	print "OK so far\n"; exit(0);
#	if ($flags && DB_CREATE) {
#		# initialize environment files
#		print "envhome=$envhome\n";
#		$env = new BerkeleyDB::Env @envargs;
#		! defined($env) and
#			addmsg(undef,
#				"no \"Env\" object ($BerkeleyDB::Error)"),
#			return undef;
#	}
#	else {
#		print "flags=$flags\n";
#	}
#	print "OK so far\n"; exit(0);
#	$env = new BerkeleyDB::Env @envargs;
#	unless (defined($env)) {
#		die "unable to get a \"BerkeleyDB::Env\" object ($BerkeleyDB::Error), stopped";
#		}
#
#=cut

	my $noid = {};		# eventual minter database handle

	# For now we use simple database-level file locking with a timeout.
	# Unlocking is implicit when the NOIDLOCK file handle is closed
	# either explicitly or upon process termination.
	#
	my $lockfile = $envhome . "lock";
	my $timeout = 5;	# max number of seconds to wait for lock
	my $locktype = (($flags & DB_RDONLY) ? LOCK_SH : LOCK_EX);

	! sysopen(NOIDLOCK, $lockfile, O_RDWR | O_CREAT) and
		addmsg(undef, "cannot open \"$lockfile\": $!"),
		return undef;
	eval {

		local $SIG{ALRM} = sub { die("lock timeout after $timeout "
			. "seconds; consider removing \"$lockfile\"\n")
		};
		alarm $timeout;		# alarm goes off in $timeout seconds
		eval {	# yyy if system has no flock, say in dbcreate profile?
			flock(NOIDLOCK, $locktype)	# blocking lock
				or die("cannot flock: $!");
		};
		alarm 0;		# cancel the alarm
		die $@ if $@;		# re-raise the exception
	};
	alarm 0;			# race condition protection
	if ($@) {			# re-raise the exception
		addmsg(undef, "error: $@");
		return undef;
	}

	my $db = tie(%$noid, "BerkeleyDB::Btree",
			-Filename => "noid.bdb",	# env has path to it
			-Flags => $flags,
## yyy			-Property => DB_DUP,
			-Env => $env)
		or addmsg(undef, "tie failed on $dbname: $BerkeleyDB::Error")
			and return undef;
	# yyy how to set error code or return string?
	#	or die("Can't open database file: $!\n");
	#print "dbopen: returning hashref=$noid, db=$db\n";
	$opendbtab{"bdb/$noid"} = $db;
	$opendbtab{"msg/$noid"} = "";
	$opendbtab{"log/$noid"} = ($log_opened ? $logfhandle : undef);

	$locktest and
		print("locktest: holding lock for $locktest seconds...\n"),
		sleep($locktest);

	return $noid;
}

# Call with number of seconds to sleep at end of each open.
# This exists only for the purpose of testing the locking mechanism.
#
sub locktest { my( $sleepvalue )=@_;
	$locktest = $sleepvalue;	# set global variable for locktest
	return 1;
}

sub dbclose { my( $noid )=@_;
	undef $opendbtab{"msg/$noid"};
	defined($opendbtab{"log/$noid"}) and
		close($opendbtab{"log/$noid"});
	undef $opendbtab{"bdb/$noid"};
	untie %$noid;
	close NOIDLOCK;		# let go of lock
}

# yyy is this needed? in present form?
#
# get next value and, if no error, change the 2nd and 3rd parameters and
# return 1, else return 0.  To start at the beginning, the 2nd parameter,
# key (key), should be set to zero by caller, who might do this:
# $key = 0; while (each($noid, $key, $value)) { ... }
# The 3rd parameter will contain the corresponding value.

sub eachnoid { my( $noid, $key, $value )=@_;
	# yyy check that $db is tied?  this is assumed for now
	# yyy need to get next non-admin key/value pair
	my $db = $opendbtab{"bdb/$noid"};
	#was: my $flag = ($key ? R_NEXT : R_FIRST);
	# fix from Jim Fullton:
	my $flag = ($key ? DB_NEXT : DB_FIRST);
	my $cursor = $db->db_cursor();
	if ($cursor->c_get($key, $value, $flag)) {
		return 0;
	}
	$_[1] = $key;
	$_[2] = $value;
	return 1;
}

# A no-op function to call instead of checkchar().
#
sub echo {
	return $_[0];
}

# $verbose is 1 if we want labels, 0 if we don't
# yyy do we need to be able to "get/fetch" with a discriminant,
#     eg, for smart multiple resolution??
sub fetch { my( $noid, $verbose, $id, @elems )=@_;

	! defined($id) and
		addmsg($noid, "error: " . ($verbose ? "fetch" : "get")
			. " requires that an identifier be specified."),
		return(undef);

	my ($hdr, $retval) = ("", "");
	$verbose and $hdr = "id:    $id"
		. (exists($$noid{"$id\t$R/h"}) ? " hold" : "") . "\n"
		. (validate($noid, "-", $id) ? "" : errmsg($noid) . "\n")
		. "Circ:  " . ($$noid{"$id\t$R/c"}
			? $$noid{"$id\t$R/c"} : "uncirculated") . "\n";

	my $db = $opendbtab{"bdb/$noid"};
	my $cursor = $db->db_cursor();

	if ($#elems < 0) {	# No elements were specified, so find them.
		my ($first, $skip, $done) = ("$id\t", 0, 0);
		my ($key, $value) = ($first, 0);
		my $status = $cursor->c_get($key, $value, DB_SET_RANGE);
		$status == 0 and
			$skip = ($key =~ m|^$first$R/|),
			$done = ($key !~ m|^$first|),
		1 or
			$done = 1
		;
		while (! $done) {
			! $skip and
				# if $verbose (ie, fetch), include label and
				# remember to strip "Id\t" from front of $key
				$retval .= ($verbose ?
					($key =~ /^[^\t]*\t(.*)/ ? $1 : $key)
						. ": " : "") . "$value\n";
			$status = $cursor->c_get($key, $value, DB_NEXT);
			$status != 0 || $key !~ /^$first/ and
				$done = 1	# no more elements under id
			or
				$skip = ($key =~ m|^$first$R/|)
			;
		}
		undef($cursor);
		! $retval and
			addmsg($noid, $hdr
				. "note: no elements bound under $id."),
			return(undef);
		return($hdr . $retval);
	}
	# yyy should this work for elem names with regexprs in them?
	# XXX idmap won't bind with longterm ???
	my $idmapped;
	for my $elem (@elems) {
		$$noid{"$id\t$elem"} and
			($verbose and
				$retval .= "$elem: "),
			$retval .= $$noid{"$id\t$elem"} . "\n"
		or
			$idmapped = id2elemval($cursor, $verbose, $id, $elem),
			($verbose and
				$retval .= ($idmapped ? "$idmapped\nnote: "
					. "previous result produced by :idmap\n"
				    : qq@error: "$id $elem" is not bound.\n@)
			or
				$retval .= "$idmapped\n"
			)
		;
	}
	undef($cursor);
	return($hdr . $retval);
}

# Generate the actual next id to give out.  May be randomly or sequentially
# selected.  This routine should not be called if there are ripe recyclable
# identifiers to use.
#
# This routine and n2xdig comprise the real heart of the minter software.
#
sub genid { my( $noid )=@_;
	dblock();

	# Variables:
	#   oacounter	overall counter's current value (last value minted)
	#   oatop	overall counter's greatest possible value of counter
	#   saclist	(sub) active counters list
	#   siclist	(sub) inactive counters list
	#   c$n/value	subcounter name's ($scn) value

	my $oacounter = $$noid{"$R/oacounter"};

	# yyy what are we going to do with counters for held? queued?

	if ($$noid{"$R/oatop"} != NOLIMIT && $oacounter >= $$noid{"$R/oatop"}) {

		# Critical test of whether we're willing to re-use identifiers
		# by re-setting (wrapping) the counter to zero.  To be extra
		# careful we check both the longterm and wrap settings, even
		# though, in theory, wrap won't be set if longterm is set.
		#
		if ($$noid{"$R/longterm"} || ! $$noid{"$R/wrap"}) {
			dbunlock();
			my $m = "error: identifiers exhausted (stopped at "
				. $$noid{"$R/oatop"} . ").";
			addmsg($noid, $m);
			logmsg($noid, $m);
			return undef;
		}
		# If we get here, term is not "long".
		logmsg($noid, temper() . ": Resetting counter to zero; "
			. "previously issued identifiers will be re-issued");
		if ($$noid{"$R/generator_type"} eq "sequential") {
			$$noid{"$R/oacounter"} = 0;
		}
		else {
			init_counters($noid);	# yyy calls dblock -- problem?
		}
		$oacounter = 0;
	}
	# If we get here, the counter may actually have just been reset.

	# Deal with the easy sequential generator case and exit early.
	#
	if ($$noid{"$R/generator_type"} eq "sequential") {
		my $id = &n2xdig($$noid{"$R/oacounter"}, $$noid{"$R/mask"});
		$$noid{"$R/oacounter"}++;	# incr to reflect new total
		dbunlock();
		return $id;
	}

	# If we get here, the generator must be of type "random".
	#
	my $len = (my @saclist = split(/ /, $$noid{"$R/saclist"}));
	if ($len < 1) {
		dbunlock();
		addmsg($noid, "error: no active counters panic, "
			. "but $oacounter identifiers left?");
		return undef;
	}
	my $randn = int(rand($len));	# pick a specific counter name
	my $sctrn = $saclist[$randn];	# at random; then pull its $n
	my $n = substr($sctrn, 1);	# numeric equivalent from the name
	#print "randn=$randn, sctrn=$sctrn, counter n=$n\t";
	my $sctr = $$noid{"$R/${sctrn}/value"};	# and get its value
	$sctr++;				# increment and
	$$noid{"$R/${sctrn}/value"} = $sctr;	# store new current value
	$$noid{"$R/oacounter"}++;		# incr overall counter - some
						# redundancy for sanity's sake

	# deal with an exhausted subcounter
	if ($sctr >= $$noid{"$R/${sctrn}/top"}) {
		my ($c, $modsaclist) = ("", "");
		# remove from active counters list
		foreach $c (@saclist) {		# drop $sctrn, but add it to
			next if ($c eq $sctrn);		# inactive subcounters
			$modsaclist .= "$c ";
		}
		$$noid{"$R/saclist"} = $modsaclist;		# update saclist
		$$noid{"$R/siclist"} .= " $sctrn";		# and siclist
		#print "===> Exhausted counter $sctrn\n";
	}

	# $sctr holds counter value, $n holds ordinal of the counter itself
	my $id = &n2xdig(
			$sctr + ($n * $$noid{"$R/percounter"}),
			$$noid{"$R/mask"});
	dbunlock();
	return $id;
}

# Identifier admin info is stored in three places:
#
#    id\t:/h	hold status: if exists = hold, else no hold
#    id\t:/c	circulation record, if it exists, is
#		    circ_status_history_vector|when|contact(who)|oacounter
#			where circ_status_history_vector is a string of [iqu]
#			and oacounter is current overall counter value, FWIW;
#			circ status goes first to make record easy to update
#    id\t:/p	pepper
#
# Returns a single letter circulation status, which must be one
# of 'i', 'q', or 'u'.  Returns the empty string on error.
#
sub get_circ_svec { my( $noid, $id )=@_;

	my $circ_rec = $$noid{"$id\t$R/c"};
	! defined($circ_rec) and
		return '';

	# Circulation status vector (string of letter codes) is the 1st
	# element, elements being separated by '|'.  We don't care about
	# the other elements for now because we can find everything we
	# need at the beginning of the string (without splitting it).
	# Let errors hit the log file rather than bothering the caller.
	#
	my $circ_svec = (split(/\|/, $circ_rec))[0];

	! defined($circ_svec) || $circ_svec eq "" and
		logmsg($noid, "error: id $id has no circ status vector -- "
			. "circ record is $circ_rec"),
		return '';
	$circ_svec !~ /^([iqu])[iqu]*$/ and
		logmsg($noid, "error: id $id has a circ status vector "
			. "containing letters other than 'i', "
			. "'q', or 'u' -- circ record is $circ_rec"),
		return '';
	return $1;
}

# As a last step of issuing or queuing an identifier, adjust the circulation
# status record.  We place a "hold" if we're both issuing an identifier and
# the minter is for "long" term ids.  If we're issuing, we also purge any
# element bindings that exist; this means that a queued identifier's bindings
# will by default last until it is re-minted.
#
# The caller must know what they're doing because we don't check parameters
# for errors; this routine is not externally visible anyway.  Returns the
# input identifier on success, or undef on error.
#
sub set_circ_rec { my( $noid, $id, $circ_svec, $date, $contact )=@_;

	my $status = 1;
	my $circ_rec = "$circ_svec|$date|$contact|" . $$noid{"$R/oacounter"};

	# yyy do we care what the previous circ record was?  since right now
	#     we just clobber without looking at it

	dblock();

	# Check for and clear any bindings if we're issuing an identifier.
	# We ignore the return value from clear_bindings().
	# Replace or clear admin bindings by hand, including pepper if any.
	# 		yyy pepper not implemented yet
	# If issuing a longterm id, we automatically place a hold on it.
	#
	$circ_svec =~ /^i/ and
		clear_bindings($noid, $id, 0),
		delete($$noid{"$id\t$R/p"}),
		($$noid{"$R/longterm"} and
			$status = hold_set($noid, $id)),
	;
	$$noid{"$id\t$R/c"} = $circ_rec;

	dbunlock();

	# This next logmsg should account for the bulk of the log when
	# longterm identifiers are in effect.
	#
	$$noid{"$R/longterm"} and
		logmsg($noid, "m: $circ_rec"
			. ($status ? "" : " -- hold failed"));

	! $status and			# must be an error in hold_set()
		return(undef);
	return $id;
}

# Get the value of any named internal variable (prefaced by $R)
# given an open database reference.
#
sub getnoid { my( $noid, $varname )=@_;
	return $$noid{"$R/$varname"};
}

#=for deleting
## Simple ancillary counter that we currently use to pair a sequence number
## with each minted identifier.  However, these are independent actions.
## The direction parameter is negative, zero, or positive to count down,
## reset, or count up upon call.  Returns the current counter value.
##
## (yyy should we make it do zero-padding on the left to a fixed width
##      determined by number of digits in the total?)
##
#sub count { my( $noid, $direction )=@_;
#
#	$direction > 0
#		and return ++$$noid{"$R/seqnum"};
#	$direction < 0
#		and return --$$noid{"$R/seqnum"};
#	# $direction must == 0
#	return $$noid{"$R/seqnum"} = 0;
#}
#=cut

# A hold may be placed on an identifier to keep it from being minted/issued.
# Returns 1 on success, 0 on error.  Sets errmsg() in either case.
#
sub hold { my( $noid, $contact, $on_off, @ids )=@_;

	# yyy what makes sense in this case?
	#! $$noid{"$R/template"} and
	#	addmsg($noid,
	#		"error: holding makes no sense in a bind-only minter."),
	#	return(0);
	! defined($contact) and
		addmsg($noid, "error: contact undefined"),
		return(0);
	! defined($on_off) and
		addmsg($noid, qq@error: hold "set" or "release"?@),
		return(0);
	! @ids and
		addmsg($noid, qq@error: no Id(s) specified@),
		return(0);
	$on_off ne "set" && $on_off ne "release" and
		addmsg($noid, "error: unrecognized hold directive ($on_off)"),
		return(0);

	my $release = $on_off eq "release";
	# yyy what is sensible thing to do if no ids are present?
	my $iderror = "";
	$$noid{"$R/genonly"} and
		($iderror = validate($noid, "-", @ids)) !~ /error:/ and
			$iderror = "";
	$iderror and
		addmsg($noid, "error: hold operation not started -- one or "
			. "more ids did not validate:\n$iderror"),
		return(0);
	my $status;
	my $n = 0;
	for my $id (@ids) {
		if ($release) {		# no hold means key doesn't exist
			logmsg($noid, temper() . " $id: releasing hold")
				if ($$noid{"$R/longterm"});
			dblock();
			$status = hold_release($noid, $id);
		}
		else {			# "hold" means key exists
			logmsg($noid, temper() . " $id: placing hold")
				if ($$noid{"$R/longterm"});
			dblock();
			$status = hold_set($noid, $id);
		}
		dbunlock();
		! $status and
			return(0);
		$n++;			# xxx should report number

		# Incr/Decrement for each id rather than by scalar(@ids);
		# if something goes wrong in the loop, we won't be way off.

		# XXX should we refuse to hold if "long" and issued?
		#     else we cannot use "hold" in the sense of either
		#     "reserved for future use" or "reserved, never issued"
		#
	}
	addmsg($noid, "ok: $n hold" . ($n == 1 ? "" : "s") . " placed");
	return(1);
}

# Returns 1 on success, 0 on error.  Use dblock() before and dbunlock()
# after calling this routine.
# yyy don't care if hold was in effect or not
#
sub hold_set { my( $noid, $id )=@_;

	$$noid{"$id\t$R/h"} = 1;		# value doesn't matter
	$$noid{"$R/held"}++;
	if ($$noid{"$R/total"} != NOLIMIT	# ie, if total is non-zero
			&& $$noid{"$R/held"} > $$noid{"$R/oatop"}) {
		my $m = "error: hold count (" . $$noid{"$R/held"}
			. ") exceeding total possible on id $id";
		addmsg($noid, $m);
		logmsg($noid, $m);
		return(0);
	}
	return(1);
}

# Returns 1 on success, 0 on error.  Use dblock() before and dbunlock()
# after calling this routine.
# yyy don't care if hold was in effect or not
#
sub hold_release { my( $noid, $id )=@_;

	delete($$noid{"$id\t$R/h"});
	$$noid{"$R/held"}--;
	if ($$noid{"$R/held"} < 0) {
		my $m = "error: hold count (" . $$noid{"$R/held"}
			. ") going negative on id $id";
		addmsg($noid, $m);
		logmsg($noid, $m);
		return(0);
	}
	return(1);
}

# Return printable form of an integer after adding commas to separate
# groups of 3 digits.
#
sub human_num { my( $num )=@_;

	$num ||= 0;
	my $numstr = sprintf("%u", $num);
	if ($numstr =~ /^\d\d\d\d+$/) {		# if num is 4 or more digits
		$numstr .= ",";			# prepare to add commas
		while ($numstr =~ s/(\d)(\d\d\d,)/$1,$2/) {};
		chop($numstr);
	}
	return $numstr;
}

# Return $elem: $val or error string.
#
sub id2elemval { my( $cursor, $verbose, $id, $elem )=@_;

	my $first = "$R/idmap/$elem\t";
	my ($key, $value) = ($first, 0);
	my $status = $cursor->c_get($key, $value, DB_SET_RANGE);
	$status and
		return "error: id2elemval: c_get status/errno ($status/$!)";
	$key !~ /^$first/ and
		return "";
	my ($pattern, $newval);
	while (1) {	# exhaustively visit all patterns for this element
		($pattern) = ($key =~ m|$first(.+)|);
		$newval = $id;
		defined($pattern) and
			# yyy kludgy use of unlikely delimiters
			(eval '$newval =~ ' . qq@s$pattern$value@ and
				# replaced, so return
				return ($verbose ? "$elem: " : "") . $newval),
			($@ and
				return "error: id2elemval eval: $@")
			;
		$cursor->c_get($key, $value, DB_NEXT) != 0 and
			return "";
		$key !~ /^$first/ and		# no match and ran out of rules
			return "";
	}
}

# Initialize counters.
#
sub init_counters { my( $noid )=@_;

	# Variables:
	#   oacounter	overall counter's current value (last value minted)
	#   saclist	(sub) active counters list
	#   siclist	(sub) inactive counters list
	#   c$n/value	subcounter name's ($n) value
	#   c$n/top	subcounter name's greatest possible value

	dblock();

	$$noid{"$R/oacounter"} = 0;
	my $total = $$noid{"$R/total"};

	my $maxcounters = 293;		# prime, a little more than 29*10
	#
	# Using a prime under the theory (unverified) that it may help even
	# out distribution across the more significant digits of generated
	# identifiers.  In this way, for example, a method for mapping an
	# identifier to a pathname (eg, fk9tmb35x -> fk/9t/mb/35/x/, which
	# could be a directory holding all files related to the named
	# object), would result in a reasonably balanced filesystem tree
	# -- no subdirectories too unevenly loaded.  That's the hope anyway.

	$$noid{"$R/percounter"} =	# max per counter, last has fewer
		int($total / $maxcounters + 1);		# round up to be > 0

	my $n = 0;
	my $t = $total;
	my $pctr = $$noid{"$R/percounter"};
	my $saclist = "";
	while ($t > 0) {
		$$noid{"$R/c${n}/top"} = ($t >= $pctr ? $pctr : $t);
		$$noid{"$R/c${n}/value"} = 0;		# yyy or 1?
		$saclist .= "c$n ";
		$t -= $pctr;
		$n++;
	}
	$$noid{"$R/saclist"} = $saclist;
	$$noid{"$R/siclist"} = "";
	$n--;

	dbunlock();

	#print "saclist: $$noid{"$R/saclist"}\nfinal top: "
	#	. $$noid{"$R/c${n}/top"} . "\npercounter=$pctr\n";
	#foreach $c ($$saclist) {
	#	print "$c, ";
	#}
	#print "\n";
}

# This routine produces a new identifier by taking a previously recycled
# identifier from a queue (usually, a "used" identifier, but it might
# have been pre-recycled) or by generating a brand new one.
#
# The $contact should be the initials or descriptive string to help
# track who or what was happening at time of minting.
#
# Returns undef on error.
#
sub mint { my( $noid, $contact, $pepper )=@_;

	! defined($contact) and
		addmsg($noid, "contact undefined"),
		return undef;

	! $$noid{"$R/template"} and
		addmsg($noid, "error: this minter does not generate "
			. "identifiers (it does accept user-defined "
			. "identifier and element bindings)."),
		return undef;
	# Check if the head of the queue is ripe.  See comments under queue()
	# for an explanation of how the queue works.
	#
	my $currdate = temper();		# fyi, 14 digits long
	my $first = "$R/q/";
	my $db = $opendbtab{"bdb/$noid"};
	! (my $cursor = $db->db_cursor()) and
		addmsg($noid, "couldn't create cursor"),
		return undef;

	# The following is not a proper loop.  Normally it should run once,
	# but several cycles may be needed to weed out anomalies with the id
	# at the head of the queue.  If all goes well and we found something
	# to mint from the queue, the last line in the loop exits the routine.
	# If we drop out of the loop, it's because the queue wasn't ripe.
	#
	my ($id, $status, $key, $qdate, $circ_svec);
	while (1) {
		$key = $first;
		$status = $cursor->c_get($key, $id, DB_SET_RANGE);
		$status and
			addmsg($noid, "mint: c_get status/errno ($status/$!)"),
			return undef;
		# The cursor, key and value are now set at the first item
		# whose key is greater than or equal to $first.  If the
		# queue was empty, there should be no items under "$R/q/".
		#
		($qdate) = ($key =~ m|$R/q/(\d{14})|);
		! defined($qdate) and			# nothing in queue
			# this is our chance -- see queue() comments for why
			($$noid{"$R/fseqnum"} > SEQNUM_MIN and
				$$noid{"$R/fseqnum"} = SEQNUM_MIN),
			last;				# so move on
		# If the date of the earliest item to re-use hasn't arrived
		$currdate < $qdate and
			last;				# move on

		# If we get here, head of queue is ripe.  Remove from queue.
		# Any "next" statement from now on in this loop discards the
		# queue element.
		#
		$db->db_del($key);
		if ($$noid{"$R/queued"}-- <= 0) {
			my $m = "error: queued count (" . $$noid{"$R/queued"}
				. ") going negative on id $id";
			addmsg($noid, $m);
			logmsg($noid, $m);
			return(undef);
		}

		# We perform a few checks first to see if we're actually
		# going to use this identifier.  First, if there's a hold,
		# remove it from the queue and check the queue again.
		#
		exists($$noid{"$id\t$R/h"}) and		# if there's a hold
			$$noid{"$R/longterm"} && logmsg($noid, "warning: id "
				. "$id found in queue with a hold placed on "
				. "it -- removed from queue."),
			next;
		# yyy this means id on "hold" can still have a 'q' circ status?

		$circ_svec = get_circ_svec($noid, $id);

		$circ_svec =~ /^i/ and
			logmsg($noid, "error: id $id appears to have been "
				. "issued while still in the queue -- "
				. "circ record is " . $$noid{"$id\t$R/c"}),
			next
		;
		$circ_svec =~ /^u/ and
			logmsg($noid, "note: id $id, marked as unqueued, is "
				. "now being removed/skipped in the queue -- "
				. "circ record is " . $$noid{"$id\t$R/c"}),
			next
		;
		$circ_svec =~ /^([^q])/ and
			logmsg($noid, "error: id $id found in queue has an "
				. "unknown circ status ($1) -- "
				. "circ record is " . $$noid{"$id\t$R/c"}),
			next
		;

		# Finally, if there's no circulation record, it means that
		# it was queued to get it minted earlier or later than it
		# would normally be minted.  Log if term is "long".
		#
		$circ_svec eq "" and
			($$noid{"$R/longterm"} && logmsg($noid, "note: "
				. "queued id $id coming out of queue on first "
				. "minting (pre-cycled)"))
		;

		# If we get here, our identifier has now passed its tests.
		# Do final identifier signoff and return.
		#
		return(set_circ_rec($noid,
			$id, 'i' . $circ_svec, $currdate, $contact));
	}

	# If we get here, we're not getting an id from the queue.
	# Instead we have to generate one.
	#
	# As above, the following is not a proper loop.  Normally it should
	# run once, but several cycles may be needed to weed out anomalies
	# with the generated id (eg, there's a hold on the id, or it was
	# queued to delay issue).
	#
	while (1) {

		# Next is the important seeding of random number generator.
		# We need this so that we get the same exact series of
		# pseudo-random numbers, just in case we have to wipe out a
		# generator and start over.  That way, the n-th identifier
		# will be the same, no matter how often we have to start
		# over.  This step has no effect when $generator_type ==
		# "sequential".
		#
		srand($$noid{"$R/oacounter"});

		# The id returned in this next step may have a "+" character
		# that n2xdig() appended to it.  The checkchar() routine
		# will convert it to a check character.
		#
		$id = genid($noid);
		! defined($id)
			and return undef;

		# Prepend NAAN and separator if there is a NAAN.
		#
		$$noid{"$R/firstpart"} and
			$id = $$noid{"$R/firstpart"} . $id;

		# Add check character if called for.
		#
		$$noid{"$R/addcheckchar"} and
			$id = &checkchar($id);

		# There may be a hold on an id, meaning that it is not to
		# be issued (or re-issued).
		#
		exists($$noid{"$id\t$R/h"}) and		# if there's a hold
			next;				# do genid() again

		# It's usual to find no circulation record.  However,
		# there may be a circulation record if the generator term
		# is not "long" and we've wrapped (restarted) the counter,
		# of if it was queued before first minting.  If the term
		# is "long", the generated id automatically gets a hold.
		#
		$circ_svec = get_circ_svec($noid, $id);

		# A little unusual is the case when something has a
		# circulation status of 'q', meaning it has been queued
		# before first issue, presumably to get it minted earlier or
		# later than it would normally be minted; if the id we just
		# generated is marked as being in the queue (clearly not at
		# the head of the queue, or we would have seen it in the
		# previous while loop), we go to generate another id.  If
		# term is "long", log that we skipped this one.
		#
		$circ_svec =~ /^q/ and
			($$noid{"$R/longterm"} && logmsg($noid,
				"note: will not issue genid()'d $id as it's "
				. "status is 'q', circ_rec is "
				. $$noid{"$id\t$R/c"})),
			next
		;

		# If the circulation status is 'i' it means that the id is
		# being re-issued.  This shouldn't happen unless the counter
		# has wrapped around to the beginning.  If term is "long",
		# an id can be re-issued only if (a) its hold was released
		# and (b) it was placed in the queue (thus marked with 'q').
		#
		$circ_svec =~ /^i/ && ($$noid{"$R/longterm"}
					|| ! $$noid{"$R/wrap"}) and
			logmsg($noid, "error: id $id cannot be "
				. "re-issued except by going through the "
				. "queue, circ_rec " . $$noid{"$id\t$R/c"}),
			next
		;
		$circ_svec =~ /^u/ and
			logmsg($noid, "note: generating id $id, currently "
				. "marked as unqueued, circ record is "
				. $$noid{"$id\t$R/c"}),
			next
		;
		$circ_svec =~ /^([^iqu])/ and
			logmsg($noid, "error: id $id has unknown circulation "
				. "status ($1), circ_rec "
				. $$noid{"$id\t$R/c"}),
			next
		;
		#
		# Note that it's OK/normal if $circ_svec was an empty string.

		# If we get here, our identifier has now passed its tests.
		# Do final identifier signoff and return.
		#
		return(set_circ_rec($noid,
			$id, 'i' . $circ_svec, $currdate, $contact));
	}
	# yyy
	# Note that we don't assign any value to the very important key=$id.
	# What should it be bound to?  Let's decide later.

	# yyy
	# Often we want to bind an id initially even if the object or record
	# it identifies is "in progress", as this gives way to begin tracking,
	# eg, back to the person responsible.
	#
}

# Record user (":/:/...") values in admin area.
sub note { my( $noid, $contact, $key, $value )=@_;
	my $db = $opendbtab{"bdb/$noid"};
	dblock();
	my $status = $db->db_put("$R/$R/$key", $value);
	dbunlock();
	$$noid{"$R/longterm"} and
		logmsg($noid, "note: note attempt under $key by $contact"
			. ($status ? "" : " -- note failed"));
	if ($status) {
		addmsg($noid, "db->db_put status/errno ($status/$!)");
		return 0;
	}
	return 1;
}

# Convert a number to an extended digit according to $mask and $generator_type
# and return (without prefix or NAAN).  A $mask character of 'k' gets
# converted to '+' in the returned string; post-processing will eventually
# turn it into a computed check character.
#
sub n2xdig { my( $num, $mask )=@_;
	my $s = '';
	my ($div, $remainder, $c);

	# Confirm well-formedness of $mask before proceeding.
	#
	$mask !~ /^[rsz][de]+k?$/
		and return undef;

	my $varwidth = 0;	# we start in fixed width part of the mask
	my @rmask = reverse(split(//, $mask));	# process each char in reverse
	while ($num != 0 || ! $varwidth) {
		if (! $varwidth) {
			$c = shift @rmask;	# check next mask character,
			! defined($c)
				|| $c =~ /[rs]/	# terminate on r or s even if
				and last;	# $num is not all used up yet
			$c =~ /e/ and
				$div = $alphacount
			or
			$c =~ /d/ and
				$div = $digitcount
			or
			$c =~ /z/ and
				$varwidth = 1	# re-uses last $div value
				and next
			or
			$c =~ /k/ and
				next
			;
#=for later
## why is this slower?  should be faster since it does NOT use regexprs
#			! defined($c) ||	# terminate on r or s even if
#				$c eq 'r' || $c eq 's'
#				and last;	# $num is not all used up yet
#			$c eq 'e' and
#				$div = $alphacount
#			or
#			$c eq 'd' and
#				$div = $digitcount
#			or
#			$c eq 'z' and
#				$varwidth = 1	# re-uses last $div value
#				and next
#			or
#			$c eq 'k' and
#				next
#			;
#=cut
		}
		$remainder = $num % $div;
		$num = int($num / $div);
		$s = $xdig[$remainder] . $s;
	}
	$mask =~ /k$/ and		# if it ends in a check character
		$s .= "+";		# represent it with plus in new id
	return $s;
}

# yyy templates should probably have names, eg, jk##.. could be jk4
#	or jk22, as in "./noid testdb/jk4  ... "

# Reads template looking for errors and returns the total number of
# identifiers that it is capable of generating, using NOLIMIT to mean
# indefinite (unbounded).  Returns 0 on error.  Variables $prefix,
# $mask, and $generator_type are output parameters.
#
# $message will always be set; 0 return with error, 1 return with synonym

#
sub parse_template { my( $template, $prefix, $mask, $gen_type, $message )=@_;

	my $dirname;
	my $msg = \$_[4];	# so we can modify $message argument easily
	$$msg = "";

	# Strip final spaces and slashes.  If there's a pathname,
	# save directory and final component separately.
	#
	$template ||= "";
	$template =~ s|[/\s]+$||;		# strip final spaces or slashes
	($dirname, $template) = $template =~ m|^(.*/)?([^/]+)$|;
	$dirname ||= "";			# make sure $dirname is defined

	! $template || $template eq "-" and
		$$msg = "parse_template: no minting possible.",
		$_[1] = $_[2] = $_[3] = "",
		return NOLIMIT;
	$template !~ /^([^\.]*)\.(\w+)/ and
		$$msg = "parse_template: no template mask - "
			. "can't generate identifiers.",
		return 0;
	($prefix, $mask) = ($1 || "", $2);

	$mask !~ /^[rsz]/ and
		$$msg = "parse_template: mask must begin with one of "
			. "the letters\n'r' (random), 's' (sequential), "
			. "or 'z' (sequential unlimited).",
		return 0;

	$mask !~ /^.[^k]+k?$/ and
		$$msg = "parse_template: exactly one check character "
			. "(k) is allowed, and it may\nonly appear at the "
			. "end of a string of one or more mask characters.",
		return 0;

	$mask !~ /^.[de]+k?$/ and
		$$msg = "parse_template: a mask may contain only the "
			. "letters 'd' or 'e'.",
		return 0;

	# Check prefix for errors.
	#
	my $c;
	my $has_cc = ($mask =~ /k$/);
	for $c (split //, $prefix) {
		if ($has_cc && $c ne '/' && ! exists($ordxdig{$c})) {
			$$msg = "parse_template: with a check character "
				. "at the end, a mask may contain only "
				. qq@characters from "$legalstring".@;
			return 0;
		}
	}

	# If we get here, the mask is well-formed.  Now try to come up with
	# a short synonym for the template; it should start with the
	# template's prefix and then an integer representing the number of
	# letters in identifiers generated by the template.  For example,
	# a template of "ft.rddeek" would be "ft5".
	#
	my $masklen = length($mask) - 1;	# subtract one for [rsz]
	$$msg = $prefix . $masklen;
	$mask =~ /^z/ and			# "+" indicates length can grow
		$$msg .= "+";

	# r means random;
	# s means sequential, limited;
	# z means sequential, no limit, and repeat most significant mask
	#   char as needed;

	my $total = 1;
	for $c (split //, $mask) {
		# Mask chars it could be are: d e k
		$c =~ /e/ and
			$total *= $alphacount
		or
		$c =~ /d/ and
			$total *= $digitcount
		or
		$c =~ /[krsz]/ and
			next
		;
	}

	$_[1] = $prefix;
	$_[2] = $mask;
	$_[3] = $gen_type = ($mask =~ /^r/ ? "random" : "sequential");
	# $_[4] was set to the synonym already
	return ($mask =~ /^z/ ? NOLIMIT : $total);
}

# An identifier may be queued to be issued/minted.  Usually this is used
# to recycle a previously issued identifier, but it may also be used to
# delay or advance the birth of an identifier that would normally be
# issued in its own good time.  The $when argument may be "first", "lvf",
# "delete", or a number and a letter designating units of seconds ('s',
# the default) or days ('d') which is a delay added to the current time;
# a $when of "now" means use the current time with no delay.

# The queue is composed of keys of the form $R/q/$qdate/$seqnum/$paddedid,
# with the correponding values being the actual queued identifiers.  The
# Btree allows us to step sequentially through the queue in an ordering
# that is a side-effect of our key structure.  Left-to-right, it is
#
#	:/q/		$R/q/, 4 characters wide
#	$qdate		14 digits wide, or 14 zeroes if "first" or "lvf"
#	$seqnum		6 digits wide, or 000000 if "lvf"
#	$paddedid	id "value", zero-padded on left, for "lvf"
#
# The $seqnum is there to help ensure queue order for up to a million queue
# requests in a second (the granularity of our clock).  [ yyy $seqnum would
# probably be obviated if we were using DB_DUP, but there's much conversion
# involved with that ]
#
# We base our $seqnum (min is 1) on one of two stored sources:  "fseqnum"
# for queue "first" requests or "gseqnum" for queue with a real time stamp
# ("now" or delayed).  To implement queue "first", we use an artificial
# time stamp of all zeroes, just like for "lvf"; to keep all "lvf" sorted
# before "first" requests, we reset fseqnum and gseqnum to 1 (not zero).
# We reset gseqnum whenever we use it at a different time from last time
# since sort order will be guaranteed by different values of $qdate.  We
# don't have that guarantee with the all-zeroes time stamp and fseqnum,
# so we put off resetting fseqnum until it is over 500,000 and the queue
# is empty, so we do then when checking the queue in mint().
#
# This key structure should ensure that the queue is sorted first by date.
# As long as fewer than a million queue requests come in within a second,
# we can make sure queue ordering is fifo.  To support "lvf" (lowest value
# first) recycling, the $date and $seqnum fields are all zero, so the
# ordering is determined entirely by the numeric "value" of identifier
# (really only makes sense for a sequential generator); to achieve the
# numeric sorting in the lexical Btree ordering, we strip off any prefix,
# right-justify the identifier, and zero-pad on the left to create a number
# that is 16 digits wider than the Template mask [yyy kludge that doesn't
# take any overflow into account, or bigints for that matter].
#
# Returns the array of corresponding strings (errors and "id:" strings)
# or an empty array on error.
#
sub queue { my( $noid, $contact, $when, @ids )=@_;

	! $$noid{"$R/template"} and
		addmsg($noid,
			"error: queuing makes no sense in a bind-only minter."),
		return(());
	! defined($contact) and
		addmsg($noid, "error: contact undefined"),
		return(());
	! defined($when) || $when !~ /\S/ and
		addmsg($noid, "error: queue when? (eg, first, lvf, 30d, now)"),
		return(());
	# yyy what is sensible thing to do if no ids are present?
	scalar(@ids) < 1 and
		addmsg($noid, "error: must specify at least one id to queue."),
		return(());
	my ($seqnum, $delete) = (0, 0, 0);
	my ($fixsqn, $qdate);			# purposely undefined

	# You can express a delay in days (d) or seconds (s, default).
	#
	if ($when =~ /^(\d+)([ds]?)$/) {	# current time plus a delay
		# The number of seconds in one day is 86400.
		my $multiplier = (defined($2) && $2 eq "d" ? 86400 : 1);
		$qdate = temper(time() + $1 * $multiplier);
	}
	elsif ($when eq "now") {	# a synonym for current time
		$qdate = temper(time());
	}
	elsif ($when eq "first") {
		# Lowest value first (lvf) requires $qdate of all zeroes.
		# To achieve "first" semantics, we use a $qdate of all
		# zeroes (default above), which means this key will be
		# selected even earlier than a key that became ripe in the
		# queue 85 days ago but wasn't selected because no one
		# minted anything in the last 85 days.
		#
		$seqnum = $$noid{"$R/fseqnum"};
		#
		# NOTE: fseqnum is reset only when queue is empty; see mint().
		# If queue never empties fseqnum will simply keep growing,
		# so we effectively truncate on the left to 6 digits with mod
		# arithmetic when we convert it to $fixsqn via sprintf().
	}
	elsif ($when eq "delete") {
		$delete = 1;
	}
	elsif ($when ne "lvf") {
		addmsg($noid, "error: unrecognized queue time: $when");
		return(());
	}

	defined($qdate) and		# current time plus optional delay
		($qdate > $$noid{"$R/gseqnum_date"} and
			$seqnum = $$noid{"$R/gseqnum"} = SEQNUM_MIN,
			$$noid{"$R/gseqnum_date"} = $qdate,
		1 or
			$seqnum = $$noid{"$R/gseqnum"}),
	1 or
		$qdate = "00000000000000",	# this needs to be 14 zeroes
	1;

	my $iderror = "";
	$$noid{"$R/genonly"} and
		($iderror = validate($noid, "-", @ids)) !~ /error:/ and
			$iderror = "";
	$iderror and
		addmsg($noid, "error: queue operation not started -- one or "
			. "more ids did not validate:\n$iderror"),
		return(());
	my $firstpart = $$noid{"$R/firstpart"};
	my $padwidth = $$noid{"$R/padwidth"};
	my $currdate = temper();
	my (@retvals, $m, $idval, $paddedid, $circ_svec);
	for my $id (@ids) {
		exists($$noid{"$id\t$R/h"}) and		# if there's a hold
			$m = qq@error: a hold has been set for "$id" and @
				. "must be released before the identifier can "
				. "be queued for minting.",
			logmsg($noid, $m),
			push(@retvals, $m),
			next
		;

		# If there's no circulation record, it means that it was
		# queued to get it minted earlier or later than it would
		# normally be minted.  Log if term is "long".
		#
		$circ_svec = get_circ_svec($noid, $id);

		$circ_svec =~ /^q/ && ! $delete and
			$m = "error: id $id cannot be queued since "
				. "it appears to be in the queue already -- "
				. "circ record is " . $$noid{"$id\t$R/c"},
			logmsg($noid, $m),
			push(@retvals, $m),
			next
		;
		$circ_svec =~ /^u/ && $delete and
			$m = "error: id $id has been unqueued already -- "
				. "circ record is " . $$noid{"$id\t$R/c"},
			logmsg($noid, $m),
			push(@retvals, $m),
			next
		;
		$circ_svec !~ /^q/ && $delete and
			$m = "error: id $id cannot be unqueued since its circ "
				. "record does not indicate its being queued, "
				. "circ record is " . $$noid{"$id\t$R/c"},
			logmsg($noid, $m),
			push(@retvals, $m),
			next
		;
		# If we get here and we're deleting, circ_svec must be 'q'.

		$circ_svec eq "" and
			($$noid{"$R/longterm"} && logmsg($noid, "note: "
				. "id $id being queued before first "
				. "minting (to be pre-cycled)")),
		1 or
		$circ_svec =~ /^i/ and
			($$noid{"$R/longterm"} && logmsg($noid, "note: "
				. "longterm id $id being queued for re-issue"))
		;

		# yyy ignore return OK?
		set_circ_rec($noid, $id,
				($delete ? 'u' : 'q') . $circ_svec,
				$currdate, $contact);

		($idval = $id) =~ s/^$firstpart//;
		$paddedid = sprintf("%0$padwidth" . "s", $idval);
		$fixsqn = sprintf("%06d", $seqnum % SEQNUM_MAX);

		dblock();

		$$noid{"$R/queued"}++;
		if ($$noid{"$R/total"} != NOLIMIT	# if total is non-zero
				&& $$noid{"$R/queued"} > $$noid{"$R/oatop"}) {

			dbunlock();

			$m = "error: queue count (" . $$noid{"$R/queued"}
				. ") exceeding total possible on id $id.  "
				. "Queue operation aborted.";
			logmsg($noid, $m);
			push @retvals, $m;
			last;
		}
		$$noid{"$R/q/$qdate/$fixsqn/$paddedid"} = $id;

		dbunlock();

		$$noid{"$R/longterm"} and
			logmsg($noid, "id: "
				. $$noid{"$R/q/$qdate/$fixsqn/$paddedid"}
				. " added to queue under "
				. "$R/q/$qdate/$seqnum/$paddedid");
		push @retvals, "id: $id";
		$seqnum and		# it's zero for "lvf" and "delete"
			$seqnum++;
	}
	dblock();
	$when eq "first" and
		$$noid{"$R/fseqnum"} = $seqnum,
	1 or
	$qdate > 0 and
		$$noid{"$R/gseqnum"} = $seqnum,
	1;
	dbunlock();
	return(@retvals);
}

# Generate a sample id for testing purposes.
sub sample{ my( $noid, $num )=@_;

	my $upper;
	! defined($num) and
		$upper = $$noid{"$R/total"},
		($upper == NOLIMIT and $upper = 100000),
		$num = int(rand($upper));
	my $mask = $$noid{"$R/mask"};
	my $firstpart = $$noid{"$R/firstpart"};
	my $func = ($$noid{"$R/addcheckchar"} ? \&checkchar : \&echo);
	return &$func($firstpart . n2xdig($num, $mask));
}

sub scope { my( $noid )=@_;

	! $$noid{"$R/template"} and
		print("This minter does not generate identifiers, but it\n"
			. "does accept user-defined identifier and element "
			. "bindings.\n");
	my $total = $$noid{"$R/total"};
	my $totalstr = human_num($total);
	my $naan = $$noid{"$R/naan"} || "";
	$naan and
		$naan .= "/";

	my ($prefix, $mask, $gen_type) =
	  ($$noid{"$R/prefix"}, $$noid{"$R/mask"}, $$noid{"$R/generator_type"});

	print "Template ", $$noid{"$R/template"}, " will yield ",
		($total < 0 ? "an unbounded number of" : $totalstr),
		" $gen_type unique ids\n";
	my $tminus1 = ($total < 0 ? 987654321 : $total - 1);

	# See if we need to compute a check character.
	my $func = ($$noid{"$R/addcheckchar"} ? \&checkchar : \&echo);
	print
	"in the range "	. &$func($naan . &n2xdig( 0, $mask)) .
	", "	 	. &$func($naan . &n2xdig( 1, $mask)) .
	", "	 	. &$func($naan . &n2xdig( 2, $mask));
	28 < $total - 1 and print
	", ..., "	. &$func($naan . &n2xdig(28, $mask));
	29 < $total - 1 and print
	", "	 	. &$func($naan . &n2xdig(29, $mask));
	print
	", ... up to "
		  	. &$func($naan . &n2xdig($tminus1, $mask))
	. ($total < 0 ? " and beyond.\n" : ".\n")
	;
	$mask !~ /^r/ and
		return 1;
	print "A sampling of random values (may already be in use): ";
	my $i = 5;
	print sample($noid) . " "
		while ($i-- > 0);
	print "\n";
	return 1;
}

# Return local date/time stamp in TEMPER format.  Use supplied time (in seconds)
# if any, or the current time.
#
sub temper { my( $time )=@_;

	my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdat)
		= localtime(defined($time) ? $time : time());
	$year += 1900;		# add the missing the century
	$mon++;			# zero-based, so increment
	return sprintf("%04.4s%02.2s%02.2s%02.2s%02.2s%02.2s",
			$year, $mon, $mday, $hour, $min, $sec);
}

# Check that identifier matches a given template, where "-" means the
# default template for this generator.  This is a complete check of all
# characteristics _except_ whether the identifier is stored in the
# database.
#
# Returns an array of strings that are messages corresponding to any ids
# that were passed in.  Error strings # that pertain to identifiers
# begin with "iderr: ".
#
sub validate { my( $noid, $template, @ids )=@_;

	my ($first, $prefix, $mask, $gen_type, $msg);
	my @retvals;

	! @ids and
		addmsg($noid, "error: must specify a template and at least "
			. "one identifier."),
		return(());
	! defined($template) and
		# If $noid is undefined, the caller looks in errmsg(undef).
		addmsg($noid, "error: no template given to validate against."),
		return(());

	if ($template eq "-") {
		($prefix, $mask) = ($$noid{"$R/prefix"}, $$noid{"$R/mask"});
		# push(@retvals, "template: " . $$noid{"$R/template"});
		if (! $$noid{"$R/template"}) {	# do blanket validation
			my @nonulls = grep(s/^(.)/id: $1/, @ids);
			! @nonulls and
				return(());
			push(@retvals, @nonulls);
			return(@retvals);
		}
	}
	elsif (! parse_template($template, $prefix, $mask, $gen_type, $msg)) {
		addmsg($noid, "error: template $template bad: $msg");
		return(());
	}

	my ($id, @maskchars, $c, $m, $varpart);
	my $should_have_checkchar = (($m = $mask) =~ s/k$//);
	my $naan = $$noid{"$R/naan"};
	ID: for $id (@ids) {
		! defined($id) || $id =~ /^\s*$/ and
			push(@retvals,
				"iderr: can't validate an empty identifier"),
			next;

		# Automatically reject ids starting with "$R/", unless it's an
		# "idmap", in which case automatically validate.  For an idmap,
		# the $id should be of the form $R/idmap/ElementName, with
		# element, Idpattern, and value, ReplacementPattern.
		#
		$id =~ m|^$R/| and
			push(@retvals, ($id =~ m|^$R/idmap/.+|
				? "id: $id"
				: "iderr: identifiers must not start"
					. qq@ with "$R/".@)),
			next;

		$first = $naan;				# ... if any
		$first and
			$first .= "/";
		$first .= $prefix;			# ... if any
		($varpart = $id) !~ s/^$first// and
#yyy		    ($varpart = $id) !~ s/^$prefix// and
			push(@retvals, "iderr: $id should begin with $first."),
			next;
		# yyy this checkchar algorithm will need an arg when we
		#     expand into other alphabets
		$should_have_checkchar && ! checkchar($id) and
			push(@retvals, "iderr: $id has a check character error"),
			next;
		## xxx fix so that a length problem is reported before (or
		# in addition to) a check char problem

		# yyy needed?
		#length($first) + length($mask) - 1 != length($id)
		#	and push(@retvals,
		#		"error: $id has should have length "
		#		. (length($first) + length($mask) - 1)
		#	and next;

		# Maskchar-by-Idchar checking.
		#
		@maskchars = split(//, $mask);
		shift @maskchars;		# toss 'r', 's', or 'z'
		for $c (split(//, $varpart)) {
			! defined($m = shift @maskchars) and
				push(@retvals, "iderr: $id longer than "
					. "specified template ($template)"),
				next ID;
			$m =~ /e/ && $legalstring !~ /$c/ and
				push(@retvals, "iderr: $id char '$c' conflicts"
					. " with template ($template)"
					. " char '$m' (extended digit)"),
				next ID
			or
			$m =~ /d/ && '0123456789' !~ /$c/ and
				push(@retvals, "iderr: $id char '$c' conflicts"
					. " with template ($template)"
					. " char '$m' (digit)"),
				next ID
			;		# or $m =~ /k/, in which case skip
		}
		defined($m = shift @maskchars) and
			push(@retvals, "iderr: $id shorter "
				. "than specified template ($template)"),
			next ID;

		# If we get here, the identifier checks out.
		push(@retvals, "id: $id");
	}
	return(@retvals);
}

1;

__END__