#!/usr/bin/perl -wT
# IBM_PROLOG_BEGIN_TAG 
# This is an automatically generated prolog. 
#  
# bos72Q src/perl/libext/Stanza/Stanza.pm 1.12.1.3 
#  
# Licensed Materials - Property of IBM 
#  
# COPYRIGHT International Business Machines Corp. 2005,2019 
# All Rights Reserved 
#  
# US Government Users Restricted Rights - Use, duplication or 
# disclosure restricted by GSA ADP Schedule Contract with IBM Corp. 
#  
# IBM_PROLOG_END_TAG 
# @(#)62      1.12.1.2  src/perl/libext/Stanza/Stanza.pm, perl_libaix, bos72D, d2015_32A0 6/29/15 13:34:55
package LibExt::Stanza;

# code starts after '=cut'

=head1 NAME

Stanza - Generic stanza file library.

=head1 DESCRIPTION

An object-oriented module ("perldoc perltoot") for stanza file manipulation.
Supports creation, file input and output, cloning, stanza insertion/deletion,
attribute insertion/deletion/modification, and reasonably complete, if simple,
querying.

=head1 SUPPORTED FILE FORMAT

This library supports stanza files according to the following formatting
specifications:

=over 2

=item Comments/Ignored Lines

Lines beginning with (whitespace followed by) any of the following characters
will be ignored: # * :

Lines consisting of only whitespace will be ignored.

Empty lines will be ignored.

=item Stanza Headers

A left-justified line ending with a colon will be parsed as a stanza header
line.  The text up to but not including the colon will be treated as the
stanza name.  The stanza name may contain any characters EXCEPT whitespace and
':'.

=item Attributes

A line with any amount of leading whitespace, followed by a "key", followed by
optional whitespace and an equals sign will be treated as an attribute belonging
to the last stanza header parsed.  An attribute line discovered before the first
stanza header in the file will generate an error.  An attribute "key" is a
sequence of any characters EXCEPT '=', beginning and ending with non-whitespace.

Text following the equals sign will be treated as the attribute's value, which
may be empty and/or surrounded by optional double quotes.

  this_is = "an attribute line"

Whitespace surrounding a value will be ignored.  Whitespace inside a value will
be preserved.  The first and last double-quote character surrounding a value
will be ignored.  Other quotes are preserved as ordinary characters.  You may
use quotes to force whitespace at the beginning or end of a value.  However,
quotes do not have a "surrounding" property.  Particularly, you do NOT span a
value across multiple lines by using an opening quote and no closing quote.  An
opening quote with no closing quote (or vice versa) is simply ignored.

Continuation lines are, however, supported by terminating a value with a
backslash at the end of the line.  Thereafter, subsequent lines, regardless of
format, are appended to the value up to and including the first line not ending
with a backslash.  The backslash is removed; the newline character is preserved;
initial whitespace in a continuation line is preserved.

  this_is = "  an attribute with forced leading whitespace\
        and a second line with a leading tab,\
and a third line with no initial whitespace,\
and a fourth line with terminal whitespace,   \
and a final line - note the legal lack of a closing double quote.

=item Uniqueness and Ordering Constraints

Stanza names need NOT be unique within a file.  Stanza order is internally
preserved - stanzae are guaranteed to be searched/output in the order read.

Attribute keys MUST be unique within a stanza, but may be duplicated in separate
stanzae.  Attribute order within a stanza is NOT preserved - attributes will be
ordered arbitrarily on output.

=back

=head1 SYNOPSIS

use Stanza;

=head2 CREATION

=over 2

=item # Empty

my $stanzafile = new LibExt::Stanza();

=item # Only one stanza

my $stanzaHash = { '/usr' => { dev       => "/dev/hd2"
                               vol       => "/usr"
                               mount     => "automatic"
                               check     => "false"
                               free      => "false"
                               vfs       => "jfs"
                               log       => "/dev/hd8"
                               type      => "bootfs"
                             }
                 };

my $stanzafile = new LibExt::Stanza($stanzaHash);

=item # Multiple stanzae

my $stanzaArray = [ $stanzaHash, # from above
                    '/var' => { dev       => "/dev/hd9var"
                                vol       => "/var"
                                mount     => "automatic"
                                check     => "false"
                                free      => "false"
                                vfs       => "jfs"
                                log       => "/dev/hd8"
                                type      => "bootfs"
                              }
                  ];

my $stanzafile = new LibExt::Stanza($stanzaArray);

=item # Deep-copy duplication

my $stanzafileCopy = new LibExt::Stanza($stanzafile);

=item # Query-copying

my $query = { FLAGS => SS_FIRST | SS_BEFORE | SS_REGEX
              STANZANAME => 'history',
              KEYVALUES => { lpp_id => '(237|238|239)',
                             ver => '3',
                             rel => '8',
                             ver => '0',
                             ver => '5302',
                           }
            };

$sfmatches = $stanzafile->grep($query);

=item # Loading a file

my $stanzafile = Stanza->loadFile("/etc/filesystems");

=item # Writing a file

  # Turn quoted values on:
  $stanzafile->dumpWithQuotes(1);
  # ...and write it:
  $stanzafile->dumpToFile("/etc/filesystems", 1);

=item # Getting stuff out

$sf->resetIterator();
for(($stanzaname, $attrhashref) = $sf->next();
    defined($stanzaname);
    ($stanzaname, $attrhashref) = $sf->next()) {
  # Do stuff
}

=item # Equality

if($sf1->equals($sf2)) { ... }

=item # Stats

my $statHash = $stanzafile->stats();

print("Number of stanzae: " . $statHash->{stanzae} . "\n");

print("Total number of attributes: " . $statHash->{kvlines} . "\n");

print("Comment/blank lines found in the file: " . $statHash->{ignorelines} . "\n");

print("Invalid lines found in the file: " . $statHash->{errors} . "\n");

=item # Clearing the number of parsing errors in Stats

$stanzafile->clearErrors();

=back

=head2 STANZA MANIPULATION

=over 2

=item # Insertion

$stanzafile->insert($stanzaHash, $query);
$stanzafile->insert($stanzaArray, $query);
$stanzafile->insert($stanzafileCopy, $query);

=item # Deletion

$stanzafile->delStanza($query);

=item # Querying

$sfmatches = $stanzafile->grep($query);

=item # Sorting

$stanzafile->sort(\&callback);

=back

=head2 ATTRIBUTE MANIPULATION

=over 2

=item # Creating/modifying

# Add or update - always succeeds if $query finds a match
$stanzafile->putAttr($query, login_name => "root");

# Fails if 'login_name' already exists
$stanzafile->addAttr($query, login_name => "root");

# Fails if 'login_name' does NOT already exist
$stanzafile->modAttr($query, login_name => "root");

=item # Querying

my $val = $stanzafile->getAttr($query, "time")

print "yes\n" if $stanzafile->has($query);

=item # Deletion

$stanzafile->delAttr($query, 'login_name');

=back

=cut

# Things this library still needs:
# o How to preserve comments in the source when modifying?
# --> Inline search & dump with callback.

use strict;
use LibExt::CatGetS;
use LibExt::libext_msg;

require Exporter;
our @ISA = qw/Exporter/;
our @EXPORT = qw/SS_FIRST SS_LAST SS_BEFORE SS_AFTER SS_ALL SS_REGEX SS_UNIQUE SQ_MATCHANY SQ_PREPEND SQ_APPEND/;

=head1 CONSTANTS

=head2 Query Structure Flags (see "USING QUERY STRUCTURES")

=over 4

=item SS_FIRST

Instructs the search engine to find the first match.

=item SS_LAST

Instructs the search engine to find the last match.

=item SS_ALL

Instructs the search engine to find all matches (may result in a list return).

=item SS_UNIQUE

Instructs the search engine to generate an error if more than one matching
stanza is found for a given query.

=item SS_BEFORE

Perform insertions before the matching stanza.

=item SS_AFTER

Perform insertions after the matching stanza.

=item SS_REGEX

Treat query structure's STANZANAME and values of KEYVALUES as regular
expressions.  Beginning (^) and end ($) anchors are implicit, so surround with
C<.*> if that's what you mean.

=back

=head2 Built-in Query Structures

=over 4

=item SQ_MATCHANY

A query structure which will match any stanza.

=item SQ_PREPEND

A query structure which will cause insertions to occur at the beginning of the
object.

=item SQ_APPEND

A query structure which will cause insertions to occur at the end of the
object.

=back

=cut

use constant {
  INDENT => "\t",
  # Stanza Search flags
  SS_FIRST  => 1,
  SS_LAST   => 2,
  SS_BEFORE => 4,
  SS_AFTER  => 8,
  SS_ALL    => 16,
  SS_REGEX  => 32,
  SS_UNIQUE => 64,
};

use constant {
  SQ_MATCHANY => { FLAGS      => SS_AFTER | SS_LAST | SS_REGEX,
                   STANZANAME => '.*',
                   KEYVALUES  => {} },
  SQ_PREPEND => {
    FLAGS => SS_BEFORE | SS_FIRST,
    STANZANAME => '',
    KEYVALUES => {},
  },
  SQ_APPEND => {
    FLAGS => SS_AFTER | SS_LAST,
    STANZANAME => '',
    KEYVALUES => {},
  },
};

# 'use constant' just makes life harder for regexes
my $re_ignoreline   = qr/^\s*(?:[#*:].*)?$/o; # A comment/blank line
my $re_stanzaheader = qr/^([^:\s]+):\s*$/o;
my $re_kvline       = qr/^\s+([^\s=]+(?:[^=]*[^\s=])?)\s*=\s*"?(.*?)"?\s*$/o;
my $re_continuation = qr/\\\s*$/o;

=head1 METHODS

=over 4

=item $sf->addAttr(QUERYSTRUCT, KEY, VALUE)

Finds the first stanza matching C<QUERYSTRUCT> and attempts to add the specified
key with the specified value.  If C<SS_ALL> is specified, adds the key to all
matching stanzae not already containing it.  Returns the number of stanzae to
which the key was added - zero when no matching stanzae were found.  (See
C<putAttr> to insert/update regardless of previous existence, and C<modAttr> to
change an existing value.)  Note: C<SS_UNIQUE> has no effect here.

=cut

sub addAttr {
  my($self, $qs, $k, $v) = @_;
  my $index = -1;
  my $count = 0;
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    if(exists($self->{DATA}->[$index]->{$sname}->{$k})) {
      next if ($qs->{FLAGS} & SS_ALL);
      return 0; # if not SS_ALL, this stanza matched the query, but didn't contain the key
    }
    $self->{DATA}->[$index]->{$sname}->{$k} = $v;
    $count++;
    return $count unless($qs->{FLAGS} & SS_ALL);
  }
  return $count;
} # addAttr

=item $sf->delAttr(QUERYSTRUCT, KEY)

Deletes the attribute whose key is C<KEY> from the first stanza matching
C<QUERYSTRUCT> AND containing that key.  If no such stanza is found, this method
returns C<undef>.  Otherwise, it returns the value of the deleted key.  (To
check for true failure, test the returned value for C<defined>, as zero or the
empty string may be valid values.)  If C<SS_ALL> is used, deletes the attribute
from all matching stanzae containing that key and returns a list of all the
values thus deleted.  Using C<SS_UNIQUE> will ensure that only one stanza
matches the query AND contains the key; the method will fail otherwise.

=cut

sub delAttr {
  my($self, $qs, $k) = @_;
  my $index = -1;
  # Run a check loop first if SS_UNIQUE was specified
  return undef unless $self->_ckUnique($qs, $k);
  my @ret = ();
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    if(exists($self->{DATA}->[$index]->{$sname}->{$k})) {
      push(@ret, delete($self->{DATA}->[$index]->{$sname}->{$k}));
      return $ret[0] unless($qs->{FLAGS} & SS_ALL);
    }
  }
  return ($qs->{FLAGS} & SS_ALL) ? @ret : undef;
} # delAttr

=item $sf->delStanza(QUERYSTRUCT)

Deletes the first stanza matching C<QUERYSTRUCT>.  You may specify C<SS_ALL> to
delete all matching stanzae.  You may specify C<SS_UNIQUE> to ensure that only
one stanza matches the query; the method will fail otherwise.  Returns the
number of stanzae deleted.

=cut

sub delStanza {
  my($self, $qs) = @_;
  my $index = -1;
  my $count = 0;
  # Run a check loop first if SS_UNIQUE was specified
  return undef unless $self->_ckUnique($qs);
  # This may be an n^2 loop for SS_ALL - we have to start each search over since
  # our indices have changed.
  while(($index = $self->_findIndex($qs, -1)) != -1) {
    # Decrement the stats for the stanza to be deleted
    $self->{STAT}->{stanzae}--;
    $self->{STAT}->{kvlines} -= scalar(keys(%{(values(%{$self->{DATA}->[$index]}))[0]}));
    splice(@{$self->{DATA}}, $index, 1);
    $count++;
    return $count unless($qs->{FLAGS} & SS_ALL);
  }
  return $count;
} # delStanza

=item $sf->dumpToFile(FILENAME[, SYNC])

Writes this object to the file specified by C<FILENAME> (which can also be a
duped fileno).  If the C<SYNC> parameter is supplied and true, the file is
committed to permanent storage by the time the function returns; otherwise,
synchronization is not guaranteed until the next time syncd runs.

=cut

sub dumpToFile {
  my($self, $f, $sync) = @_;
  $f or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_FILENO(), "%s: 1240-001 Expected a filename or fileno dupe.\n", __PACKAGE__), return(undef);
  require IO::File;
  my $fh = IO::File->new(">$f") or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_FILECREATE(), "%s: 1240-002 Couldn't create %s.\n", __PACKAGE__, $f), return(undef); 
  $fh->autoflush(1) if $sync;
  my($s, $a, $k, $v);
  my $quote = $self->{CONTROL}->{quotes}?'"':'';
  for(@{$self->{DATA}}) {
    # Reset the 'each' iterator, just in case
    keys(%$_);
    ($s, $a) = each(%$_);
    $fh->print("\n$s:\n");
    # Reset the 'each' iterator, just in case
    keys(%$a);
    while(($k, $v) = each(%$a)) {
      $fh->print(INDENT . "$k = $quote" . join("\\\n", split(/\n/, $v)) . "$quote\n");
    }
  }
  $fh->sync() if $sync;
  $fh->close();
  return 1;
} # dumpToFile

=item $sf->$dumpWithQuotes(BOOL)

Sets an internal variable indicating whether the C<dumpToFile> method should
surround attribute values with double quotes.  If the parameter evaluates to
true, quotes will be used.  If the parameter is defined, but false, quotes will
not be used.  If the parameter is missing or C<undef>, the setting will be
toggled.  Returns the previous value of the setting.  Off (no quotes) by
default.

=cut

sub dumpWithQuotes {
  my($self, $bool) = @_;
  my $ret = $self->{CONTROL}->{quotes};
  if(defined($bool)) {
    $bool = $bool?1:0;
  }
  else { # toggle
    $bool = $ret?0:1;
  }
  $self->{CONTROL}->{quotes} = $bool;
  return $ret;
}

=item $sf->equals(COMPAREE)

Deep-checks the C<COMPAREE> for equality to the object being operated on.
Stanzae must be in the same order and contain the same keys with the same
values.  Returns true if the objects are equal; false otherwise.

=cut

sub equals {
  my($self, $subj) = @_;
  unless($subj->isa(__PACKAGE__)) {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_CALL_EQUALS(), "%s: 1240-003 Must call equals() with a %s object.\n", __PACKAGE__, __PACKAGE__);
    return undef;
  }
  my $j = 0;
  return 0 unless $self->{STAT}->{stanzae} == $subj->{STAT}->{stanzae};
  return 0 unless $self->{STAT}->{kvlines} == $subj->{STAT}->{kvlines};
  # Do not check ignores and errors
  # This should be redundant - should be the same as stanzae stat.
  return 0 unless scalar(@{$self->{DATA}}) == scalar(@{$subj->{DATA}});
  my($i, $s1, $s2, $a1, $a2, $k, $v);
  for($i = 0; $i < @{$self->{DATA}}; $i++) {
    # reset the 'each' iterator, just in case
    keys(%{$self->{DATA}->[$i]});
    keys(%{$subj->{DATA}->[$i]});
    # Now grab the stanza for both
    ($s1, $a1) = each(%{$self->{DATA}->[$i]});
    ($s2, $a2) = each(%{$subj->{DATA}->[$i]});
    return 0 unless $s1 eq $s2;
    return 0 unless scalar(keys(%$a1)) == scalar(keys(%$a2));
    while(($k, $v) = each(%$a1)) {
      return 0 unless(exists($a2->{$k}) && ($a2->{$k} eq $v));
    }
  }
  return 1;
} # equals

=item $sf->getAttr(QUERYSTRUCT, KEY)

Returns the value of the C<KEY> attribute for the stanza or stanzae matching
C<QUERYSTRUCT>.  Using C<SS_ALL> will return a list of (zero or more) values
from all matching stanzae; otherwise, a single scalar value is returned
(C<undef> if no matching stanza or key was found).  Using C<SS_UNIQUE> will
cause the method to fail if more than one stanza matches C<QUERYSTRUCT>.

=cut

sub getAttr {
  my($self, $qs, $k) = @_;
  my $index = -1;
  my @ret = ();
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    # Uncomment the following condition to make the requested key significant in the search
    # if(exists($self->{DATA}->[$index]->{$sname}->{$k})) {
      push(@ret, $self->{DATA}->[$index]->{$sname}->{$k});
      return $ret[0] unless($qs->{FLAGS} & (SS_ALL | SS_UNIQUE));
    # }
  }
  # Using this instead of _ckUnique to avoid the extra loop-through.  We have
  # that luxury since this method is a non-destructive getter.
  if(($qs->{FLAGS} & SS_UNIQUE) && (scalar(@ret) > 1)) {
    # warn("SS_UNIQUE was specified, but found " . scalar(@ret) . " matching stanzae.");
    return undef;
  }
  # If we get here, SS_ALL was set and we have an array - return it.
  return ($qs->{FLAGS} & SS_ALL) ? @ret : $ret[0];
} # getAttr

=item $sf->grep(QUERYSTRUCT)

Returns a new Stanza object containing (deep-copied) stanzae from C<$sf> which
match C<QUERYSTRUCT>.  C<SS_ALL> will cause all matching stanzae to appear in
the returned object.  C<SS_UNIQUE> will cause the method to fail if more than
one stanza matches the query.

=cut

sub grep {
  my($self, $qs) = @_;
  my $index = -1;
  my $ret = $self->new();
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $ret->insert($self->{DATA}->[$index]);
    return $ret unless($qs->{FLAGS} & (SS_ALL | SS_UNIQUE));
  }
  # Using this instead of _ckUnique to avoid the extra loop-through.  We have
  # that luxury since this method is a non-destructive getter.
  if(($qs->{FLAGS} & SS_UNIQUE) && ($ret->{STAT}->{stanzae} > 1)) {
    # warn("SS_UNIQUE was specified, but found " . $ret->{STAT}->{stanzae} . " matching stanzae."); #"
    return undef;
  }
  return $ret;
} # grep

=item $sf->has(QUERYSTRUCT)

Boolean method returning true if the specified query matches.  Similar to
C<grep>, but does not create or return a new object.

=cut

sub has {
  my($self, $query) = @_;
  return undef unless $query;
  my $index = -1;
  # Spin through a check loop if SS_UNIQUE is set.
  return undef unless $self->_ckUnique($query);
  return ($self->_findIndex($query, $index) != -1);
} # has

=item $sf->insert(SUBJECT, [QUERY])

C<SUBJECT> may be a string representing the name of the stanza to insert (it
will be created empty), a hash representing a single stanza, a reference to an
array of such hashes, or a full-fledged Stanza object.  C<QUERY> may be a string
representing a stanza name.  If so, the C<SUBJECT> stanza or stanzae will be
inserted after the last stanza of that name.  C<QUERY> may also be a full Query
Structure, in which case the insertion happens according to the matches and
flags implied thereby.  If C<QUERY> is not specified, C<SUBJECT> is appended.
C<SS_UNIQUE> will cause this method to fail, returning C<undef>, if more than
one stanza matches the C<QUERY>.  C<SS_ALL> has no effect.  (Particularly, it
does not cause a separate copy of the C<SUBJECT> to be inserted after each
matching stanza.)  On success, the updated object is returned.

=cut

sub insert {
  my($self, $ref, $query) = @_;
  unless(defined($ref)) {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_UNDEF_ARG(), "%s: 1240-004 %s->insert() got an undef first argument.\n", __PACKAGE__, __PACKAGE__);
    return undef;
  }
  unless(defined($query)) { # No query provided - use the "any" query.
    $query = SQ_MATCHANY;
  }
  elsif(ref($query) ne 'HASH') { # Assume $query is a string representing an exact stanza name
    $query = { FLAGS      => SS_AFTER | SS_LAST,
               STANZANAME => $query,
               KEYVALUES  => {} };
  }
  my @insertArray = ();
  my $type = ref($ref);
  # Insert another Stanza object by inserting its DATA array
  #no warnings 'deprecated';
  #use UNIVERSAL qw/isa/;
  if($type && $type->isa(__PACKAGE__)) {
    return $self->insert($ref->{DATA}, $query);
  }
  if($type eq '') { # Empty named stanza
    unless("$ref:" =~ $re_stanzaheader) {
      print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_INVALID_STANZA(), "%s: 1240-005 %s is not a valid stanza name.\n", __PACKAGE__, "'$ref'");
      return undef;
    }
    $ref = { $ref => {} };
    $type = "HASH";
  }
  if($type eq "HASH") {
    # Construct a stanza sub-object and build an array to splice in
    my $sh = $self->_buildAndStatStanzaHASH($ref) or return undef; # error printed by _bASSH()
    push(@insertArray, $sh);
  }
  elsif($type eq "ARRAY") {
    for(@$ref) {
      my $sh = $self->_buildAndStatStanzaHASH($_) or return undef; # error printed by _bASSH()
      push(@insertArray, $sh);
    }
  }
  # Now @insertArray is ready to splice.  Find the right position.
  my($splicepos, $count) = (-1, 0);
  # Spin through a check loop if SS_UNIQUE is set.
  return undef unless $self->_ckUnique($query);
  $splicepos = $self->_findIndex($query, -1);
  # Now some post-search double-checking.
  # If we never found the search term, we alter our splice position based on
  # SS_FIRST vs. SS_LAST.
  if($splicepos == -1) {
    $splicepos = ($query->{FLAGS} & SS_LAST) ? scalar(@{$self->{DATA}}) - 1 : 0;
  }
  # At this point, we're set up to insert BEFORE.
  if($query->{FLAGS} & SS_AFTER) {
    $splicepos++;
  }
  # Now make sure we don't try to splice past the ends of the array.
  if($splicepos > scalar(@{$self->{DATA}})) {
     $splicepos = scalar(@{$self->{DATA}});
  }
  if($splicepos < 0) { # This should never happen
     $splicepos = 0;
  }
  # Now we have a splice position.  Do it.
  splice(@{$self->{DATA}}, $splicepos, 0, @insertArray);
  return $self;
} # insert

=item my $stanzafile = Stanza->loadFile(FILENAME)

CONSTRUCTOR - Reads the file specified by C<FILENAME> (which can also be a duped
fileno) and parses it into a new Stanza object, which it returns.  Formatting
errors in the file are C<warn>ed.

=cut

my $_loadFile_parser;
BEGIN {
  my $parsemode;
  if(defined($parsemode = $ENV{LIBEXT_STANZA_PARSE_MODE}) && ($parsemode =~ /^perl/io)) {
    $_loadFile_parser = \&_loadFile_Perl;
  }
  else {
    require XSLoader;
    XSLoader::load('LibExt::Stanza');
    $_loadFile_parser = \&LibExt::Stanza::boh_callbacks_fp;
  }
}

sub loadFile {
  my($proto, $f) = @_;
  defined($f) or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_FILENO(), "%s: 1240-001 Expected a filename or fileno dupe.\n", __PACKAGE__), return(undef);
  my $fh;
  open($fh, $f) or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_R_OPEN(), "%s: 1240-006 Couldn't open %s for reading.\n", __PACKAGE__, $f), return(undef); 
  my $h = $_loadFile_parser->($fh) or return undef;
  close($fh) or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_CLOSE(), "%s: 1240-007 close() failed: %s\n", __PACKAGE__, $!); 
  my $class = ref($proto) || $proto;
  return bless($h, $class);
} # loadFile

sub _loadFile_Perl {
  my $fh = shift;
  my($tmp, $sname, $k, $v);
  my @fobj = (); # Array of hashes.  Each hash is stanzaname => {kvhash}.  Each
                 # kvhash is key => value.
  my $stats = {
    ignores => 0,
    stanzae => 0,
    kvlines => 0,
    errors  => 0
  };
  while(<$fh>) {
    if(/$re_ignoreline/) {
      ++$stats->{ignores};
    }
    elsif(($tmp) = /$re_stanzaheader/) {
      ++$stats->{stanzae};
      $sname = $tmp;
      push(@fobj, { $sname => {} });
    }
    elsif(($k, $v) = /$re_kvline/) {
      if(@fobj) { # we've seen a stanza header
        if(exists($fobj[$#fobj]->{$sname}->{$k})) {
          ++$stats->{errors};
          print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_DUP_KEY(), "%s: 1240-008 Keys must be unique within a stanza.  Found more than one '%s' in '%s':\n%s\n", __PACKAGE__, $k, $sname, $_);
        }
        else {
          ++$stats->{kvlines};
          if($v =~ /$re_continuation/) {
            $v =~ s/$re_continuation//;
            while(defined($tmp = <$fh>) && ($tmp =~ /$re_continuation/)) {
              $tmp =~ s/$re_continuation//;
              $v .= "\n$tmp";
            }
            if(defined($tmp)) {
              $tmp =~ s/"\s*$//;
              $v .= "\n$tmp";
            }
          }
          $fobj[$#fobj]->{$sname}->{$k} = (defined($v)?$v:'');
        }
      }
      else { # We haven't seen a stanza header - this kvline is out of place.
        ++$stats->{errors};
        print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_KEY_VAL(), "%s: 1240-009 Unexpected key/value line before first stanza header:\n%s\n", __PACKAGE__, $_);
      }
    }
    else {
      ++$stats->{errors};
      print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_INVALID_LINE(), "%s: 1240-010 Unrecognized line in stanza file:\n%s\n", __PACKAGE__, $_);
    }
  }
  return { DATA => \@fobj,
           STAT => $stats };
} # _loadFile_Perl

=item $sf->modAttr(QUERYSTRUCT, KEY, VALUE)

Attempts to change the C<KEY> attribute to C<VALUE> in the stanza or stanzae
matching C<QUERYSTRUCT>.  This method will fail if there are no stanzae which
match C<QUERYSTRUCT> AND contain C<KEY>.  Using C<SS_ALL> will cause all
matching stanzae to be updated.  Using C<SS_UNIQUE> will cause the method to
fail, returning C<undef>, if more than one stanza matches C<QUERYSTRUCT>.
Returns the (scalar) prior value of the attribute unless C<SS_ALL> is used, in
which case the method returns a list of all the prior values.  On any failure,
C<undef> is returned.  (Be sure to use C<defined> to check for failure, as zero
or the empty string may be valid prior values.)

=cut

sub modAttr {
  my($self, $qs, $k, $v) = @_;
  # Run a check loop first if SS_UNIQUE was specified
  return undef unless $self->_ckUnique($qs);
  my $index = -1;
  my @ret = ();
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    unless(exists($self->{DATA}->[$index]->{$sname}->{$k})) {
      next if ($qs->{FLAGS} & SS_ALL);
      return undef;
    }
    push(@ret, $self->{DATA}->[$index]->{$sname}->{$k});
    $self->{DATA}->[$index]->{$sname}->{$k} = $v;
    unless($qs->{FLAGS} & SS_ALL) {
      return $ret[0];
    }
  }
  return @ret;

} # modAttr

=item my $stanzafile = Stanza->new([SUBJECT])

CONSTRUCTOR - Creates a new Stanza object.  C<SUBJECT> may be a hash
representing a single stanza, an array of such hashes, or a full-fledged Stanza
object.  If defined, it is deep-copied into the new object.  If C<SUBJECT> is
empty or undefined, an empty Stanza object is returned.

=cut

sub new {
  my($proto, $ref) = @_;
  my $class = ref($proto) || $proto;
  my $ret = bless { DATA => [],
                    STAT => {
                              ignores => 0,
                              stanzae => 0,
                              kvlines => 0,
                              errors  => 0
                            },
                    CONTROL => {
                                 iterator => 0,
                                 quotes   => 0,
                               },
                  }, $class;
  # Okay to create an empty stanza list
  return (defined($ref) ? $ret->insert($ref, SS_AFTER | SS_LAST) : $ret);
} # new

=item ($stanzaname, $attrhashref) = $sf->next()

Returns the next stanza (according to the internal iterator), or C<undef> if the
end of the structure has been reached.  Use C<resetIterator()> to reset to the
beginning.  The returned structure is an array whose first element is the stanza
name and whose second is a hash reference of the key/value pairs in the stanza.
The hash reference points to the actual in-memory data in the object; modifying
its contents will modify the object.

=cut

sub next {
  my $self = shift;
  $self->{CONTROL}->{iterator} = 0 unless defined $self->{CONTROL}->{iterator};
  my $ret = $self->{DATA}->[$self->{CONTROL}->{iterator}++];
  return undef unless defined $ret;
  my $sname = (keys(%$ret))[0];
  return ($sname, $ret->{$sname});
} # next

=item $sf->putAttr(QUERYSTRUCT, KEY, VALUE)

Finds the stanza matching C<QUERYSTRUCT> and adds the specified key with the
specified value, overwriting any previous value.  On success, the INSERTED value
is returned.  On failure (no stanzae matched C<QUERYSTRUCT>), C<undef> is
returned.  Using C<SS_ALL> will cause all matching stanzae to be updated, and a
list of the inserted values (which should all be the same) is returned.
(Evaluating this list in scalar context will give the number of stanzae
updated.) C<SS_UNIQUE> will cause the method to fail if more than one stanza
matches C<QUERYSTRUCT> (C<KEY> is NOT taken into account for uniqueness.)  (See
C<addAttr> to insert conditional on previous nonexistence, and C<modAttr> to
change an existing value.)

=cut

sub putAttr {
  my($self, $qs, $k, $v) = @_;
  my $index = -1;
  my @ret = ();
  # Run a check loop first if SS_UNIQUE was specified
  return undef unless $self->_ckUnique($qs);
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    $self->{DATA}->[$index]->{$sname}->{$k} = $v;        # \ reverse these two lines
    push(@ret, $self->{DATA}->[$index]->{$sname}->{$k}); # / to return the PRIOR values
    unless($qs->{FLAGS} & SS_ALL) {
      return $ret[0];
    }
  }
  return @ret;
} # putAttr

=item $sf->resetIterator()

Resets the internal iterator so further calls to next() will start back at the
beginning of the structure.

=cut

sub resetIterator {
  my $self = shift;
  $self->{CONTROL}->{iterator} = 0;
  return 1;
} # resetIterator

=item $sf->sort(\&callback)

Sorts the stanzae according to the callback routine, or in lexical order if no
callback is provided.  The callback routine should expect the names of the two
stanzae to be compared in @_.  There is currently no (good) way to sort based on
the contents of the stanzae - only on their names.  The sort routine will
preserve the existing order of stanzae with the same name (see perldoc -f
'sort').  For convenience, returns the sorted object.

=cut

sub sort {
  my($self, $callback) = @_;
  defined($callback) or $callback = sub { $a cmp $b };
  my $sorter = sub($$) {
    my($s1, $s2) = @_;
    local($a, $b) = ((keys(%$s1))[0], (keys(%$s2))[0]);
    return $callback->($a, $b);
  };
  unless(ref($callback) eq 'CODE') {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_SORT_ERR(), "%s: 1240-011 Callback to 'sort' method must be a CODE reference.\n", __PACKAGE__);
    return undef;
  }
  $self->{DATA} = [sort($sorter @{$self->{DATA}})];
  return $self;
} # sort

=item $hash = $sf->stats()

Returns a reference to a hash of statistics for this Stanza object.  The hash
looks like this:

{ stanzae => <n>, # Total number of stanzae
  kvlines => <n>, # Total number of attributes across all stanzae
  ignores => <n>, # Total number of blank/comment lines - only nonzero when loadFile() was used
  errors  => <n>  # Total number of unrecognized lines - only nonzero when loadFile() was used
}

The hash is backed to the actual object, so do not change it.

=cut

sub stats {
  return shift->{STAT};
} # stats

=item $sf->clearErrors()

Resets the number of parsing errors, $self->{STAT}->{errors}, to 0.

=back 

=cut

sub clearErrors {
  shift->{STAT}->{errors} = 0;
  return 1;
}

=head1 USING QUERY STRUCTURES

Methods which accept a C<QUERYSTRUCT> perform some manner of search on the
object's data before executing their intended operation.  A Query Structure
looks like this:

my $qs = { FLAGS => <OR'ed SS_ flags>,
           STANZANAME => <string>,
           KEYVALUES => { keyname => value,
                          keyname => value,
                          ... }
         };

=over 4

=item FLAGS

The value associated with C<FLAGS> consists of zero or more C<SS_*> constants
logically ORed together (see C<CONSTANTS>.)

=item STANZANAME

Only stanzae with this name will be considered further.  Note that if C<FLAGS>
contains C<SS_REGEX>, this value will be treated as the guts of a regular
expression, with start-of-string and end-of-string anchors implied.  For
example, if C<SS_REGEX> is in use and $qs->{STANZANAME} is "foo", only stanzae
whose names match C</^foo$/> will be considered further.  If C<SS_REGEX> is not
in use, the stanza name must be an exact string match (C<eq>).

=item KEYVALUES

This hash of zero or more key/value pairs is only used if C<STANZANAME> yielded
a match.  All key/value pairs are implicitly logically ANDed.  (If you need OR,
chances are you're working on the same key across your ORs, so use C<SS_REGEX>
and a good regex instead.)  As with C<STANZANAME>, regexes have an implicit
beginning and end anchor, so "foo" translates to C</^foo$/>, not C</foo/>.
C<SS_REGEX> applies to BOTH stanza names and attribute values (not to key names,
which are always matched exactly).  Specifying an empty hash in C<KEYVALUES>
will match everything - use this technique to match on only the stanza name.

=item Examples

None written at this time.  Please contact the author if you feel this omission
must be rectified.

=back

=cut

##############################
##############################
#### PRIVATE METHODS/SUBS ####
##############################
##############################

##################################
# METHOD _buildAndStatStanzaHASH #
##################################
#
# USAGE
# $stanzafileObj->_buildAndStatStanzaHASH($stanzaref)
#
# Accepts, validates, and returns a stanza sub-object thus:
#
# { stanzaname => { key => value,
#                   key => value,
#                   ... }
# }
#
# ...and adds its stats to $self, but does NOT add the actual stanza sub-object
# to $self.  That's the responsibility of the calling method, so it can
# determine the appropriate position.
#
# Note that this performs a deep copy of its parameter.  The advantages:
# o Validation
# o Can do stats during processing
# o Non-destructive - original hash can be reused (not sure why this would be needed)
##################################
sub _buildAndStatStanzaHASH {
  my($self, $ref) = @_;
  my($s, $a, $k, $v);
  unless(ref($ref) eq "HASH") {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_NO_HASH(), "%s: 1240-012 Expected hash reference.\n", __PACKAGE__);
    return undef;
  }
  unless(scalar(keys(%$ref)) == 1) {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_INVALID_HASH_FMT(), "%s: 1240-013 Improper stanza hash format - outer hash must have only one key (the stanza name).\n", __PACKAGE__);
    return undef;
  }
  # Reset the 'each' iterator, just in case
  keys(%$ref);
  ($s, $a) = each(%$ref);
  # Make sure the stanza name is a string
  unless(defined($s) && !ref($s) && (_trim(\$s) ne "")) {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_EMPTY_STANZA_NAME(), "%s: 1240-014 Stanza name must be a nonempty string.\n", __PACKAGE__);
    return undef;
  }
  # Make sure the attribute k/v pair is a hash
  unless(ref($a) eq "HASH") {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_HASH_OF_HASH(), "%s: 1240-015 Expected a hash of hashes.\n", __PACKAGE__);
    return undef;
  }
  my $data = { $s => {} };
  my $kvlines = 0;
  # Reset the 'each' iterator, just in case
  keys(%$a);
  while(($k, $v) = each(%$a)) {
    # Make sure the key is a nonempty string
    unless(defined($k) && !ref($k) && (_trim(\$k) ne "")) {
      print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_EMPTY_ATTR_KEY(), "%s: 1240-016 Attribute key must be a nonempty string.\n", __PACKAGE__);
      return undef;
    }
    # Make sure the value is a string
    unless(defined($k) && !ref($k)) {
      print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_NON_STR_ATTR(), "%s: 1240-017 Attribute value must be a string.\n", __PACKAGE__);
      return undef;
    }
    $data->{$s}->{$k} = $v;
    $kvlines++;
  }
  $self->{STAT}->{stanzae}++;
  $self->{STAT}->{kvlines} += $kvlines;
  return $data;
}

####################
# METHOD _ckUnique #
####################
#
# USAGE
# return undef unless $stanzafile->_ckUnique($query);
# return undef unless $stanzafile->_ckUnique($query, $key);
#
# If SS_UNIQUE is set in $query and more than one stanza matches, not[prints a
# warning (including the number of matching stanzae) and] returns false.
# Otherwise (zero or one matches) returns true.  If $key is defined, stanzae
# must ALSO contain that key in order to count.
##################################
sub _ckUnique {
  my($self, $qs, $key) = @_;
  # Short-circuit unless the query asks for uniqueness
  return 1 unless($qs->{FLAGS} & SS_UNIQUE);
  my($index, $count) = (-1, 0);
  my $sname = ($qs->{FLAGS} & SS_REGEX) ? undef : $qs->{STANZANAME};
  while(($index = $self->_findIndex($qs, $index)) != -1) {
    $sname = (keys(%{$self->{DATA}->[$index]}))[0] if($qs->{FLAGS} & SS_REGEX);
    $count++ if(!defined($key) || exists($self->{DATA}->[$index]->{$sname}->{$key}));
  }
  if($count > 1) {
    # warn("SS_UNIQUE was specified, but found $count matching stanzae.");
    return undef;
  }
  return 1;
}

#####################
# METHOD _findIndex #
#####################
#
# USAGE
# $stanzafile->_findIndex($querystruct, $startpos)
#
# Searches through $self's DATA for the next entry matching the query term.
# Understands FLAGS.  Given the special $startpos of "-1", this method will
# start searching at the beginning or end of the list, depending whether
# SS_FIRST or SS_LAST is set.  This method will also always move one stanza in
# the appropriate direction (according to SS_FIRST or SS_LAST) BEFORE starting
# to search.  This makes it possible to write your loop like this:
#
# my $index = -1;
# while(($index = $sf->_findIndex($qs, $index)) != -1) { ... }
#
# RETURNS
# The index of the term found, or -1 on any error or failure.
# TO REITERATE, THIS METHOD DOES NOT RETURN ZERO ON FAILURE since 0 is a valid
# array index.
##################################
sub _findIndex {
  my($self, $qs, $start) = @_;
  $qs && (ref($qs) eq 'HASH') or print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_INVALID_QUERY(), "%s: 1240-018 Missing/invalid query structure.\n", __PACKAGE__), return -1;
  $qs->{FLAGS} = SS_FIRST unless $qs->{FLAGS};
  if(!defined($start) || ($start == -1)) {
    $start = ($qs->{FLAGS} & SS_LAST) ? @{$self->{DATA}} : -1;
  }
  if($qs->{FLAGS} & SS_LAST) {
    for(my $ret = $start - 1; $ret >= 0; $ret--) {
      return $ret if _stanzamatch($self->{DATA}->[$ret], $qs);
    }
  }
  else { # SS_FIRST by default
    for(my $ret = $start + 1; $ret < @{$self->{DATA}}; $ret++) {
      return $ret if _stanzamatch($self->{DATA}->[$ret], $qs);
    }
  }
  return -1;
}

#########################
# FUNCTION _stanzamatch #
#########################
#
# USAGE
# _stanzamatch($subjectStanza, $querystruct)
#
# Returns true if the $subjectStanza matches the query specified by
# $querystruct, false otherwise.
##################################
sub _stanzamatch {
  my($subj, $qs) = @_;
  print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_NON_STANZA_HASH(), "%s: 1240-019 Subject must be a stanza hash.\n", __PACKAGE__), return undef unless $subj && (ref($subj) eq 'HASH');
  print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_NON_HASH_QUERY(), "%s: 1240-020 Query struct must be a hash.\n", __PACKAGE__), return undef unless $qs && (ref($qs) eq 'HASH');
  my $flags = $qs->{FLAGS};
  # Reset the 'each' iterator, just in case
  keys(%$subj);
  my($s, $a) = each(%$subj);
  return undef unless _strmatch($s, $qs->{STANZANAME}, $flags);
  # Reset the 'each' iterator, just in case
  keys(%{$qs->{KEYVALUES}});
  while(my($k, $v) = each(%{$qs->{KEYVALUES}})) {
    return undef unless (exists($a->{$k}) && _strmatch($a->{$k}, $v, $flags));
  }
  return 1;
}

######################
# FUNCTION _strmatch #
######################
#
# USAGE
# _strmatch($subjectString, $queryString, $flags)
#
# Returns true if the $subjectString matches the $queryString.  Performs either
# string equality or regular expression match, depending on whether the SS_REGEX
# bit is set in $flags.  (Other flags may be used in later implementations.)
##################################
sub _strmatch {
  my($subj, $query, $flags) = @_;
  return undef unless defined $subj;
  $flags = 0 unless defined $flags;
  $query = '' unless defined $query;
  return(($flags & SS_REGEX) ? ($subj =~ m/^$query$/) : ($subj eq $query));
}

##################
# FUNCTION _trim #
##################
#
# USAGE
# _trim(\$s)
# if(_trim(\$s) ne '') { ... }
#
# Takes a string reference and trims surrounding whitespace.
# AFFECTS THE STRING PASSED IN, AND RETURNS A COPY OF IT.
##################################
sub _trim {
  my $sref = shift;
  unless(ref($sref) eq "SCALAR") {
    print_msg(MSGSET_ERRWARN(), MSG_LIB_STANZA_NON_SCALAR(), "%s: 1240-021 Expected scalar (string) reference.\n", __PACKAGE__);
    return '';
  }
  # I think this two-line version is a bit faster than s/^\s*(.*?)\s*$/$1/
  # because I don't have to save the backreference.
  $$sref =~ s/^\s*//o;
  $$sref =~ s/\s*$//o;
  return $$sref;
}

######################
# FUNCTION print_msg #
######################
#
# USAGE
# print_msg($msg_set, $msg_num, $pfstring, $args)
##################################
sub print_msg {
  my $msg_set = shift;
  my $msg_num = shift; 
  my $pfstr = shift;

  if ($msg_set == MSGSET_WORD() || $msg_set == MSGSET_INFO()) {
    printf(STDOUT catgets(MF_LIBEXT(), $msg_set, $msg_num, $pfstr), @_);
  } else { # MSGSET_USAGE, MSGSET_ERRWARN
    printf(STDERR catgets(MF_LIBEXT(), $msg_set, $msg_num, $pfstr), @_);
  } 
}

1;