package SIL::Shoe::Data;
=head1 NAME
SIL::Shoe::Data - Class for handling Shoebox databases
=head1 SYNOPSIS
require SIL::Shoe::Data;
$s = SIL::Shoe::Data->new("infile.db", $key);
$s->index;
$s->findrecord("Mine");
$s->readrecord(\@fieldkeys);
$s->{'newfield'} = "Hi there mum!";
push(@fieldkeys, "newfield");
$s->printrecord(\*FILEHANDLE, @fieldkeys)
=head1 DESCRIPTION
This class provides support for Standard Format databases as generated by
Shoebox. The class supports indexing, incrementing, etc. and as such holds
static information regarding a database.
The following methods are available:
=cut
$VERSION = "1.10"; # MJPH 14-AUG-2006 Add field methods
# $VERSION = "1.09"; # MJPH 30-JUN-2006 Add printheader
# $VERSION = "1.08"; # MJPH 19-MAY-2006 Fix complex indexing for many keys in a record
# $VERSION = "1.07"; # MJPH 21-FEB-2005 Add \_DateStampHasFourDigitYear field (' DateStamp' = 4)
# $VERSION = "1.06"; # MJPH 20-JAN-2005 Fix multiline key fields
# $VERSION = "1.05"; # MJPH 10-JUN-2004 Add md5 and line counts on indexing
# $VERSION = "1.04"; # MJPH 3-APR-2003 Add auto key searching, md5, locational reading
# $VERSION = "1.0003"; # MJPH 9-DEC-1998 Add noblank creation option.
# $VERSION = "1.0000";
# $VERSION = "1.0001"; # MJPH 29-JUN-1998 Debugged nostripnl, added VERSION, map comment
# $VERSION = "1.0002"; # MJPH 28-JUL-1998 Get index and findrecord working
use strict;
use Carp();
use IO::File;
use Digest::MD5;
=head2 SIL::Shoe::Data->new("filename", "key", 'attrname' => 'value', ...)
Creates a new Shoebox object corresponding to the SF database in "filename".
The keyfield marker is given at this point also. If key is blank, then it will
be guessed by looking for the first marker in the file (excluding \_sh).
Extra attributes are also supported including:
=over 4
=item nostripnl
If set, instructs that multi-line fields not be joined into a single line by a
space.
=item nostripws
If set, disables the default stripping of whitespace from the start and end
of a field's data.
=item allfields
Make sure that all fields are output by printrecord, even those not in the
given list.
=item noblank
Indicates that records printed via printrecord should not have a following
blank line.
=item unicode
Assume the file is UTF8 unicode data otherwise process as bytes
=item nointernal
Do not keep track of fields and their positions within the record
=back
=cut
sub new
{
my $class = shift;
my $file = shift;
my $key = shift;
my ($self, $fh);
my (%attrs) = @_;
foreach (keys %attrs) { $self->{" $_"} = $attrs{$_}; }
if (ref $file)
{ $fh = $file; }
elsif ($self->{' unicode'})
{ $fh = IO::File->new($file, "<:utf8") || return Carp::croak("Unable to open Shoebox file $file"); }
else
{ $fh = IO::File->new($file, "<:bytes") || return Carp::croak("Unable to open Shoebox file $file"); }
# notice we can use fields starting with space for internals
# since SF markers can't start with space.
$self->{' key'} = $key;
$self->{' INFILE'} = $fh;
$self->{' thisloc'} = 0; # where we are following the last ReadRecord
$self->{' loc'} = 0; # the location of the last findrecord
while ($_ = $fh->getline)
{
if (m/^\\_sh\s+(\S+)\s+(\S+)\s+(.*?)\s*$/oi)
{
$self->{' Version'} = $1;
$self->{' CSum'} = $2; # always 400 in SH4
$self->{' Type'} = $3;
last if $key;
}
elsif (m/^\\_DateStampHasFourDigitYear/o)
{
$self->{' DateStamp'} = 4;
}
elsif (m/^\\(\S+)/oi)
{
next if ($1 eq '_sh');
$self->{' key'} = $1 unless $key;
last;
}
}
$fh->seek(0, 0);
bless $self, $class;
}
=head2 $s->index("otherkey")
"otherkey" is optional and allows indexing on a key other than the key field.
Indexes the database according to the key field. Since Shoebox seems happy to
hold its index in memory, so shall we. This index supports multiple records
identically keyed.
The internal structure of the index is a hash of index entries each of which
is an array of locations in the file. Thus:
$s->{' index'}{$entry}[$num]
returns a C<seek> location into the file. Note also that the index can be kept
and saved and a new index created as needed.
This direct access is useful, for example in finding all the values of a given
sfm:
$s->index("auth");
@auths = keys %{$s->{' index'}};
otherkey may take multiple values, in which case the index is indexed on the
values of each field in the list passed, joined by a null (\000)
$s->index("title", "auth");
$myind = $s->{' index'}{"mybook\000me"}[0];
for records with multiple occurrences of an indexed field, then multiple index
entries will me made. Thus
\entry 001
\title mybook
\title mybook: mysubtitle
\auth me
\auth myself
would result in 4 index entries for this one record:
"mybook\000me", "mybook\000myself",
"mybook: mysubtitle\000me", "mybook: mysubtitle\000myself"
Indexing also allows for some options, these are passed as a hash reference as
the first parameter, as in:
$s->index({'-lines' => 1}, "title", "auth");
=over 4
=item -lines
Keeps the line number of the key field of each record in the index. The values
are stored in the corresponding hash:
$s->{' lineindex'}
=item -md5
Stores an md5 hash of each record according to the index entries in
$s->{' md5index'}
=back
=cut
sub index
{
my ($self, $opts, @keys) = @_;
my ($file, $loc, $keyloc, $index, @val, %keys, $k);
my ($val, $v, $lcount, $md5, $lloc, $lindex, $mindex);
if (defined $opts && ref($opts) ne 'HASH')
{
unshift (@keys, $opts);
$opts = {};
}
$keys[0] = $self->{' key'} unless ($keys[0]);
%keys = map{$_, $k++} @keys;
$file = $self->{' INFILE'};
$file->seek(0, 0);
$md5 = Digest::MD5->new() if ($opts->{'-md5'});
while ($_ = $file->getline)
{
$lcount++;
if (m/^\\$self->{' key'}\s+/)
{
if (defined @val)
{
my ($md5loc) = $md5->digest if ($opts->{'-md5'});
foreach $v (@val)
{
my ($vk) = join("\000", @{$v});
push (@{$index->{$vk}}, $keyloc);
push (@{$lindex->{$vk}}, $lloc) if ($opts->{'-lines'});
push (@{$mindex->{$vk}}, $md5loc) if ($opts->{'-md5'});
}
undef @val;
}
$md5 = Digest::MD5->new() if ($opts->{'-md5'});
$keyloc = $loc;
$lloc = $lcount;
}
if (m/^\\(\S+)\s+(.*?)\s*$/o)
{
$k = $1;
$val = $2;
if (defined $keys{$k})
{
my (@copy);
if (defined $val[0][$keys{$k}]) # side effect, defines @val
{
foreach $v (grep {$_->[$keys{$k}] eq $val[0][$keys{$k}]} @val)
{ push(@copy, [@$v]); }
foreach $v (@copy)
{ $v->[$keys{$k}] = $val; }
push (@val, @copy);
}
else
{
foreach $v (@val)
{ $v->[$keys{$k}] = $val; }
}
}
}
$loc = $file->tell;
chomp;
$md5->add($_) if ($opts->{'-md5'});
}
if (defined @val)
{
my ($md5loc) = $md5->digest if ($opts->{'-md5'});
foreach $v (@val)
{
my ($vk) = join("\000", @{$v});
push (@{$index->{$vk}}, $keyloc);
push (@{$lindex->{$vk}}, $lloc) if ($opts->{'-lines'});
push (@{$mindex->{$vk}}, $md5loc) if ($opts->{'-md5'});
}
}
$self->{' index'} = $index;
$self->{' lineindex'} = $lindex if ($opts->{'-lines'});
$self->{' md5index'} = $mindex if ($opts->{'-md5'});
$file->seek(0, 0);
$self;
}
=head2 $s->findrecord("value");
Searches through the database for a key with the given value. Identical
matching only is supported. If the database has been indexed, then the index
is used in preference, which may, of course, be indexed on a different field.
For multiple records with the same index entries, multiple calls to findrecord
with the same value will refer to each record in turn.
Calling findrecord clears the readrecord marker which allows sequential
reading of records.
Returns undef if no record found and at the end of a list of records. Thus:
while ($s->findrecord("FirstOnly")) { ... }
Will process all the records indexed by "FirstOnly".
findrecord may also be passed a list of values in which case they are joined
appropriately for searching a corresponding index with that value.
=cut
sub findrecord
{
my ($self, @val) = @_;
my ($index, @locs, $loc, $file, $key);
my ($i, $val, $oldloc);
$val = join("\000", @val);
$oldloc = $self->{' thisloc'};
$self->{' thisloc'} = -1;
if ($index = $self->{' index'})
{
$self->{' find'} = $val;
return undef unless defined $index->{$val};
@locs = @{$index->{$val}};
for ($i = 0; $i <= $#locs; $i++)
{
if ($self->{' loc'} == $locs[$i])
{
if ($i == $#locs)
{
$self->{' thisloc'} = $oldloc;
$self->{' loc'} = -1;
return undef;
}
$self->{' loc'} = $locs[$i + 1];
last;
}
}
$self->{' loc'} = $locs[0] unless ($i <= $#locs);
seek($self->{' INFILE'}, $self->{' loc'}, 0);
return $self;
} else {
$key = $self->{' key'};
$file = $self->{' INFILE'};
$file->seek($self->{' loc'}, 0);
$file->getline if ($self->{' find'} eq $val);
$self->{' find'} = $val;
$loc = $file->tell;
while ($_ = $file->getline)
{
if (m/^\\$key\s+$val\s*$/o)
{
$self->{' loc'} = $loc;
$file->seek($loc, 0);
return $self;
}
$loc = $file->tell;
}
return undef;
}
}
=head2 $s->readrecord(\@fieldlist [, $loc])
Reads a record from the current location as located by the last findrecord or
readrecord whichever is later. Notice that if the last findrecord failed then
the readrecord will start from the beginning of the file.
\@fieldlist is optional.
Multiple fields with the same name are *not* stored as an array, as might be
expected, but as fields with spaces in as in f, f 0, f 1, etc. The precise
names are returned in \@fieldlist. The advantage of this method is that users
just wanting the first occurrence don't have to decide whether something is
coming as an array or as a string. The other alternative would have been to
make every field an array resulting in major hassle for people.
A way of turning the multiple fields into an array is to use a C<map>
function of the form:
@array = map { m/^$fieldname(?:\s+\d+)?$/o ? $s->{$_} : () } @fieldlist;
which returns an array of fields called $fieldname from $s.
$loc specifies a location in the file to read from. Usually it is undefined,
but if set allows for control over which record is read.
Returns undef if no record read (probably due to end of file).
=cut
sub readrecord
{
my ($self, $flist, $loc) = @_;
my ($file) = $self->{' INFILE'};
my ($key) = $self->{' key'};
my ($stripnl) = not $self->{' nostripnl'};
$loc = $self->{' thisloc'} unless (defined $loc);
my ($foundkey) = 0;
$loc = $self->{' loc'} if ($loc == -1); # done a findrecord
my ($current_key, $old_key, $data);
# first wipe out any fields stored in $self
my (@f) = keys %$self;
foreach (@f) { delete $self->{$_} unless (m/^\s/oi); }
@$flist = () if (defined $flist);
unless ($self->{' nointernal'})
{
$self->{' field_list'} = [];
$self->{' field_lkup'} = {};
}
$file->seek($loc, 0);
while($_ = $file->getline)
{
chomp;
if (m/^\\$key\s*(.*?)\s*$/)
{
$self->{$key} = $1;
push(@{$flist}, $key) if (defined $flist);
unless ($self->{' nointernal'})
{
push (@{$self->{' field_list'}}, $key);
$self->{' field_lkup'}{$key} = 0;
}
$foundkey = 1;
last;
}
$loc = $file->tell;
}
return undef unless $foundkey; # didn't find a key so return nothing
# read fields until find next key found
$current_key = $key; # in nomans land, between key and first field
$loc = $file->tell; # get current location so can return here if
# find a new key.
while($_ = $file->getline)
{
chomp;
if (m/^\\(\S*)\s*(.*?)\s*$/oi) # is this a field marker of some kind?
{
$old_key = $current_key;
$current_key = $1;
$data = $2;
if (defined $old_key && !defined $self->{' nostripws'})
{
$self->{$old_key} =~ s/\s*$//o;
$self->{$old_key} =~ s/^\s*//o;
}
if ($current_key =~ m/^\\*$/) # deleted records in old
# SHv1.2 are ignored. Handles backup files
{
undef $current_key;
next;
}
if ($current_key =~ m/^$key$/)
{
$file->seek($loc, 0); # go to start of line
last; # and exit
}
# iterate to find a new unique field of the same name, for multiple
# fields of the same name in a record. The resultant subsequent
# field names are of the form "field n" where n is a number.
while (defined $self->{$current_key})
{
my ($suff, $pref);
if ($current_key =~ m/ /o) # already got a long field name
{
$suff = $';
$pref = $`; #'
$suff++; # incremement the final no.
}
else # set up the first value
{
$suff = 0;
$pref = $current_key;
}
$current_key = $pref . " " . $suff; # make a new field
} # name
$self->{$current_key} = $data; # store the value
push(@$flist, $current_key) if (defined $flist);
unless ($self->{' nointernal'})
{
push (@{$self->{' field_list'}}, $current_key);
$self->{' field_lkup'}{$current_key} = $foundkey++;
}
# add the field name to the list
}
elsif (defined $current_key) # a continuation line?
{
s/\s*$//o; # clear line final spaces
s/^\s*//o if ($stripnl); # perhaps strip initial ws
$self->{$current_key} .= ($stripnl ? " " : "\n") . $_;
}
}
continue
{
$loc = $file->tell; # keep track of a possible new record
}
$self->{$current_key} =~ s/\s*$// if (defined $current_key); # clear up at eof
$self->{' thisloc'} = $loc;
$self;
}
=head2 $s->proc_record($sub [,$loc])
Iterates over each line of a record calling $sub for each line, which has
been chomped. Uses the same approach as readrecord in choosing where to read.
=cut
sub proc_record
{
my ($self, $sub, $loc) = @_;
my ($file) = $self->{' INFILE'};
my ($key) = $self->{' key'};
$loc ||= $self->{' thisloc'};
$loc = $self->{' loc'} if ($loc == -1);
$file->seek($loc, 0);
while($_ = $file->getline)
{
chomp;
if (m/^\\$key([ \t]+|$)/)
{
&{$sub}($_);
while ($_ = $file->getline)
{
chomp;
last if (/^\\$key([ \t]+|$)/);
&{$sub}($_);
$loc = $file->tell;
}
last;
}
$loc = $file->tell;
}
$self->{' thisloc'} = $loc;
return $self;
}
=head2 $s->allof($key)
Returns all occurrences of a given key, in field order
=cut
sub allof
{
my ($self, $key) = @_;
my ($k) = qr/^$key(?:\s|$)/;
return sort grep {/$k/} keys %{$self};
}
=head2 $s->insert_field($offset, $field)
Inserts a field into the field list at the given offset. Returns the new name
of the field (to account for multiple identical fields).
=cut
sub insert_field
{
my ($self, $ind, $field) = @_;
my ($hash) = $self->{' field_lkup'};
my ($h);
while (defined $hash->{$field}) { $field =~ s/(\s\d*)?$/" " . ($1 + 1)/oe; }
splice(@{$self->{' field_list'}}, $ind, 0, $field);
foreach $h (keys %$hash)
{ $hash->{$h}++ if ($hash->{$h} >= $ind); }
$hash->{$field} = $ind;
return $field;
}
=head2 $s->delete_field($field)
Deletes a particular field from the field list (note not all occurrences, just
the specific field)
=cut
sub delete_field
{
my ($self, $field) = @_;
my ($hash) = $self->{' field_lkup'};
my ($ind) = defined $hash->{$field} ? $hash->{$field} : return;
my ($h);
splice(@{$self->{' field_list'}}, $ind, 1);
foreach $h (keys %$hash)
{ $hash->{$h}-- if ($hash->{$h} > $ind); }
delete $hash->{$ind};
}
=head2 $s->rename_field($old, $new)
Renames all occurrences of old fields to new ones changing the database as well
=cut
sub rename_field
{
my ($self, $old, $new) = @_;
my ($k);
foreach $k (grep {m/^$old(?:\s|$)/} @{$self->{' field_list'}})
{
my ($t) = "$k";
my ($newf) = $new;
while (defined $self->{' field_lkup'}{$newf}) { $newf =~ s/(\s\d*)?$/" ". ($1 + 1)/oe; }
$self->{$newf} = delete $self->{$t};
$self->{' field_list'}[$self->{' field_lkup'}{$t}] = $newf;
$self->{' field_lkup'}{$newf} = delete $self->{' field_lkup'}{$t};
}
}
=head2 $s->offsetof_field($field)
Returns the field index of a particular field
=cut
sub offsetof_field
{
my ($self, $field) = @_;
return $self->{' field_lkup'}{$field};
}
=head2 $s->printheader(\*FILE)
Prints out the header information
=cut
sub printheader
{
my ($sh, $file) = @_;
printf $file "\\_sh %s %d %s\n", $sh->{' Version'}, $sh->{' CSum'}, $sh->{' Type'};
print $file "\\_DateStampHasFourDigitYear\n" if ($sh->{' DateStamp'} == 4);
print $file "\n";
}
=head2 $s->printrecord(\*FILE, @fieldlist)
Prints out an SH record with fields in the given order. If $s->{' allfields'} is
set, then also add onto the end of the list, all unmentioned fields.
=cut
sub printrecord
{
my ($self, $file, @fields) = @_;
my ($f);
if ($self->{' allfields'})
{
if (defined $self->{' field_list'})
{
foreach $f (@{$self->{' field_list'}})
{ push(@fields, $f) unless (grep($_ eq $f, @fields)); }
}
else
{
foreach $f (grep {m/^\S/o} keys %$self ) # for each field possible
{ # add to the list if not alread there
push (@fields, $f) unless (grep($_ eq $f, @fields));
}
}
}
foreach $f (@fields) # iterate over the marker list
{
if ($f =~ m/ /o) # need to trim fieldname kludging
{ print $file "\\$` "; }
else
{ print $file "\\" ."$f "; }
print $file "$self->{$f}\n";
}
print $file "\n" unless $self->{' noblank'}; # print a blank line at the end of a record
}
=head2 $s->rewind([$pos])
Rewinds the current pointer to the start (or $pos if given)
=cut
sub rewind
{ $_[0]->{' thisloc'} = $_[0]->{' loc'} = $_[1]; }
=head2 $s->DESTROY()
The destructor for an SF database. Closes the file before disappearing.
=cut
sub DESTROY
{
my ($self) = @_;
$self->{' INFILE'}->close;
undef;
}
1;
__END__
# now the test program
package main;
require SIL::Shoe::Data;
$s = SIL::Shoe::Data->new($ARGV[0], $ARGV[1]);
while ($s->readrecord(\@keys)) { $s->printrecord(\*STDOUT, @keys); }