package DBM::DBass;
use DB_File;
use Fcntl;
use strict;
use vars '$VERSION';
require 5.004;
$VERSION = $VERSION = '0.54';
################################ CONSTANTS ################################
sub LOCK_SH () { 1 }
sub LOCK_EX () { 2 }
sub LOCK_UN () { 8 }
######################### ESCAPE MARKUP CHARACTERS #########################
sub escape (@) {
my @in = @_;
for (@in) {
next unless defined $_;
s/&/&/gs;
s/'/'/gs;
s/</</gs;
s/>/>/gs;
s/"/"/gs;
}
wantarray ? @in : shift @in || '';
}
######################## UNESCAPE MARKUP CHARACTERS ########################
sub unescape (@) {
my @in = @_;
for (@in) {
next unless defined $_;
s/&/&/gs;
s/'/'/gs;
s/</</gs;
s/>/>/gs;
s/"/"/gs;
}
wantarray ? @in : shift @in || '';
}
############################ EXPRESS DESTRUCTOR ############################
sub close {
my $self = shift;
&{$self->{'_SUBS'}->{'destroy'}} ($self);
}
############################## DELETE RECORDS ##############################
sub delete {
my $self = shift;
&{$self->{'_SUBS'}->{'delete'}} ($self, @_);
}
################################ API CHECK ################################
sub gestalt {
return unless (@_ > 1 && $_[0] eq '-api' && defined &{$_[1] . '_new'});
1;
}
################################ READ KEYS ################################
sub keys {
my $self = shift;
&{$self->{'_SUBS'}->{'keys'}} ($self);
}
################################ TAG RECORD ################################
sub neo_tag ($$) {
return undef unless @_ > 1;
my ($root, $in) = @_;
my $ref = ref $in;
join '', (
'<?xml version="1.0" standalone="yes"?><', $root, '>',
($ref eq 'ARRAY' ? neo_taglist ($in)
: ($ref eq 'HASH' ? neo_taghash ($in)
: neo_tagscalar ($in))),
'</', $root, '>'
);
}
sub neo_taghash ($) {
my $in = shift;
my @out = ('<hash>');
for (sort keys %$in) {
push @out, '<key>' . escape ($_) . '</key><value>';
my $ref = ref $in->{$_};
push @out,
$ref eq 'ARRAY' ? neo_taglist ($in->{$_})
: ($ref eq 'HASH' ? neo_taghash ($in->{$_})
: neo_tagscalar ($in->{$_}));
push @out, '</value>';
}
join '', (@out, '</hash>');
}
sub neo_taglist ($) {
my $in = shift;
my @out = ('<list>');
for (@$in) {
push @out, '<value>';
my $ref = ref $_;
push @out, $ref eq 'ARRAY' ? neo_taglist ($_)
: ($ref eq 'HASH' ? neo_taghash ($_)
: neo_tagscalar ($_));
push @out, '</value>';
}
join '', (@out, '</list>');
}
sub neo_tagscalar ($) {
join '', ('<scalar>', escape (shift), '</scalar>');
}
############################### UNTAG RECORD ###############################
{
my @tagged = ();
sub neo_untaghash () {
my %out = ();
my $key = '';
while (@tagged) {
my $in = shift @tagged;
return \%out if $in eq '<\/hash>';
if ($in eq '<key>') {
while (@tagged) {
$in = shift @tagged;
last if $in eq '</key>';
$key = unescape ($in) if length $in;
}
} elsif ($in eq '<value>') {
while (@tagged) {
$in = shift @tagged;
next unless (length $in && length $key);
last if $in eq '</value>';
if ($in eq '<hash>') {
$out{$key} = &neo_untaghash;
} elsif ($in eq '<list>') {
$out{$key} = &neo_untaglist;
} elsif ($in eq '<scalar>') {
$out{$key} = &neo_untagscalar;
}
}
}
}
\%out;
}
sub neo_untaglist () {
my @out = ();
while (@tagged) {
my $in = shift @tagged;
return \@out if $in eq '</list>';
next if $in ne '<value>';
while (@tagged) {
$in = shift @tagged;
next unless length $in;
last if $in eq '</value>';
if ($in eq '<hash>') {
push @out, &neo_untaghash;
} elsif ($in eq '<list>') {
push @out, &neo_untaglist;
} elsif ($in eq '<scalar>') {
push @out, &neo_untagscalar;
}
}
}
\@out;
}
sub neo_untagscalar () {
my $out = '';
while (@tagged) {
my $in = shift @tagged;
return $out if $in eq '</scalar>';
$out .= unescape ($in) if length $in;
}
$out;
}
sub neo_untag ($$) {
my $root = shift;
@tagged = split /(<.+?>)/, shift;
while (@tagged) {
my $in = shift @tagged;
if ($in eq '<?xml version="1.0" standalone="yes"?>') {
while (@tagged) {
$in = shift @tagged;
if ($in =~ /^<$root>/) {
while (@tagged) {
$in = shift @tagged;
if ($in eq '<hash>') {
return neo_untaghash;
} elsif ($in eq '<list>') {
return neo_untaglist;
} elsif ($in eq '<scalar>') {
return neo_untagscalar;
}
}
}
}
}
}
}
}
################################# NEO READ #################################
sub neo_read {
my $self = shift;
my %argv = @_;
my $ref;
for (defined $argv{'-keys'} && defined $argv{'-root'}
? (($ref = ref $argv{'-keys'}) eq 'ARRAY'
? @{$argv{'-keys'}}
: ($ref eq 'HASH' ? keys %{$argv{'-keys'}} : $argv{'-keys'}))
: (defined $self->{'_HASHREF'}
? keys %{$self->{'_HASHREF'}}
: keys %{$self->{'_UNTAGGED'}})) {
next if defined $self->{'_UNTAGGED'}->{$_};
$self->{'_UNTAGGED'}->{$_} =
neo_untag $argv{'-root'}, $self->{'_HASHREF'}->{$_}
if (defined $self->{'_HASHREF'} &&
defined $self->{'_HASHREF'}->{$_});
}
$self->{'_UNTAGGED'};
}
################################ NEO WRITE ################################
sub neo_write {
my $self = shift;
return 1 unless defined $self->{'_OBJ'};
die unless $self->{'_MODE'} =~ /[+>]/;
my %argv = @_;
die unless defined $argv{'-hash'} && defined $argv{'-root'};
for (keys %{$argv{'-hash'}}) {
next unless defined $argv{'-hash'}->{$_};
$self->{'_HASHREF'}->{$_} =
neo_tag $argv{'-root'}, $argv{'-hash'}->{$_};
$self->{'_UNTAGGED'}->{$_} = $argv{'-hash'}->{$_};
}
$self->{'_OBJ'}->sync;
}
############################### CONSTRUCTOR ###############################
sub new {
my $class = shift;
my %argv = ('-api' => 'neo', @_);
my $api = $argv{'-api'};
my %subs = (
'neo' => {
'delete' => \&xeen_delete,
'destroy' => \&xeen_destroy,
'keys' => \&xeen_keys,
'new' => \&xeen_new,
'read' => \&neo_read,
'write' => \&neo_write
},
'xeen' => {
'delete' => \&xeen_delete,
'destroy' => \&xeen_destroy,
'keys' => \&xeen_keys,
'new' => \&xeen_new,
'read' => \&xeen_read,
'write' => \&xeen_write
}
);
die unless defined $subs{$api};
my $self = {};
$class = ref $class || $class;
bless ($self, $class);
$self->{'_SUBS'} = $subs{$api};
&{$self->{'_SUBS'}->{'new'}} ($self, %argv);
$self;
}
############################### READ RECORDS ###############################
sub read {
my $self = shift;
&{$self->{'_SUBS'}->{'read'}} ($self, @_);
}
############################## WRITE RECORDS ##############################
sub write {
my $self = shift;
&{$self->{'_SUBS'}->{'write'}} ($self, @_);
}
################################ TAG RECORD ################################
sub xeen_tag {
my $root = shift;
return undef unless @_;
my $out = xeen_taghash (@_);
$root = escape $root;
'<?xml version="1.0" standalone="yes"?><' .
$root . '>' . $out . '</' . $root . '>';
}
sub xeen_taghash {
my $in = shift;
my $out = '';
for (sort keys %$in) {
my $key = escape $_;
my $ref = ref $in->{$_};
if ($ref eq 'ARRAY') {
$out .= xeen_taglist ($key, \@{$in->{$_}});
} elsif ($ref eq 'HASH') {
$out .= join '', (
'<', $key, '>', xeen_taghash ($in->{$_}), '</', $key, '>'
);
} elsif (defined $in->{$_}) {
$out .= join '', (
'<', $key, '>', escape ($in->{$_}), '</', $key, '>'
);
}
}
$out;
}
sub xeen_taglist {
my ($key, $in) = @_;
my $top = '<' . $key . '>';
my $end = '</' . $key . '>';
my $out = '';
for (@$in) {
my $ref = ref $_;
if ($ref eq 'HASH') {
$out .= join '', ($top, xeen_taghash ($_), $end);
} elsif (defined $_) {
$out .= join '', ($top, escape ($_), $end);
}
}
$out;
}
############################### UNTAG RECORD ###############################
{
my @tagged = ();
sub xeen_untag ($$) {
my $root = escape shift;
@tagged = split /(<.+?>)/, shift;
while (@tagged) {
my $in = shift @tagged;
if ($in eq '<?xml version="1.0" standalone="yes"?>') {
while (@tagged) {
$in = shift @tagged;
if ($in =~ /^<$root>/) {
my $untagged = xeen_untaghash ($root);
return $untagged->{$root};
}
}
}
}
}
sub xeen_untaghash {
my $root = shift;
my %out = ();
while (@tagged) {
my $in = shift @tagged;
next unless $in;
return \%out if $in =~ /^<\/$root>/;
my $unroot = unescape $root;
if ($in =~ /^<(.+?)>/) {
my $tag = $1;
my $untagged = xeen_untaghash ($tag);
$tag = unescape $tag;
if (defined $out{$unroot} && defined $out{$unroot}{$tag}) {
if (ref $out{$unroot}{$tag} eq 'ARRAY') {
push @{$out{$unroot}{$tag}}, $untagged->{$tag};
next;
}
my $val = $out{$unroot}{$tag};
undef $out{$unroot}{$tag};
@{$out{$unroot}{$tag}} = ($val, $untagged->{$tag});
next;
}
$out{$unroot}{$tag} = $untagged->{$tag};
next;
}
$out{$unroot} = unescape $in;
}
}
}
############################### XEEN DELETE ###############################
sub xeen_delete {
my $self = shift;
return 1 unless defined $self->{'_OBJ'};
die unless $self->{'_MODE'} =~ /[+>]/;
my %argv = @_;
if (defined $argv{'-keys'}) {
my $ref = ref $argv{'-keys'};
if ($ref eq 'ARRAY') {
for (@{$argv{'-keys'}}) {
delete $self->{'_HASHREF'}->{$_}
if exists $self->{'_HASHREF'}->{$_};
delete $self->{'_UNTAGGED'}->{$_}
if exists $self->{'_UNTAGGED'}->{$_};
}
} elsif ($ref eq 'HASH') {
for (keys %{$argv{'-keys'}}) {
delete $self->{'_HASHREF'}->{$_}
if exists $self->{'_HASHREF'}->{$_};
delete $self->{'_UNTAGGED'}->{$_}
if exists $self->{'_UNTAGGED'}->{$_};
}
} else {
my $key = $argv{'-keys'};
delete $self->{'_HASHREF'}->{$key}
if exists $self->{'_HASHREF'}->{$key};
delete $self->{'_UNTAGGED'}->{$key}
if exists $self->{'_UNTAGGED'}->{$key};
}
} else {
$self->{'_HASHREF'} = {};
$self->{'_UNTAGGED'} = {};
}
$self->{'_OBJ'}->sync;
}
############################# XEEN DESTRUCTOR #############################
sub xeen_destroy {
my $self = shift;
return 1 unless defined $self->{'_OBJ'};
undef $self->{'_OBJ'};
untie %$self->{'_HASHREF'};
if ($^O eq 'MacOS' || $^O eq 'MacPerl') {
chmod 0666, $self->{'_LOCK'};
} else {
flock $self->{'_FH'}, LOCK_UN;
CORE::close $self->{'_FH'};
}
}
################################ XEEN KEYS ################################
sub xeen_keys {
my $self = shift;
keys %{$self->{'_HASHREF'}};
}
############################# XEEN CONSTRUCTOR #############################
sub xeen_new {
my $self = shift;
my %argv = ('-mode' => 0644, @_);
die unless $argv{'-file'};
($self->{'_FILE'} = $argv{'-file'}) =~ s/^([+<>]+)//;
$self->{'_MODE'} = $1 || '';
$self->{'_LOCK'} = $argv{'-lock'};
$self->{'_UNTAGGED'} = {};
if ($^O eq 'MacOS' || $^O eq 'MacPerl') {
chmod 0444, $self->{'_LOCK'};
} else {
if ($self->{'_MODE'} =~ /[+>]/) {
open FH, '>>' . $self->{'_LOCK'} or die $!;
unless (flock FH, LOCK_EX) {
CORE::close FH;
die;
}
} else {
open FH, $self->{'_LOCK'} or die $!;
unless (flock FH, LOCK_SH) {
CORE::close FH;
die;
}
}
$self->{'_FH'} = *FH;
}
die unless
$self->{'_OBJ'} = tie %{$self->{'_HASHREF'}}, 'DB_File',
$self->{'_FILE'}, O_CREAT | O_RDWR, $argv{'-mode'};
}
################################ XEEN READ ################################
sub xeen_read {
my $self = shift;
my %argv = @_;
my $ref;
for (defined $argv{'-keys'} && defined $argv{'-root'}
? (($ref = ref $argv{'-keys'}) eq 'ARRAY'
? @{$argv{'-keys'}}
: ($ref eq 'HASH' ? keys %{$argv{'-keys'}} : $argv{'-keys'}))
: (defined $self->{'_HASHREF'}
? keys %{$self->{'_HASHREF'}}
: keys %{$self->{'_UNTAGGED'}})) {
next if defined $self->{'_UNTAGGED'}->{$_};
$self->{'_UNTAGGED'}->{$_} =
xeen_untag $argv{'-root'}, $self->{'_HASHREF'}->{$_}
if (defined $self->{'_HASHREF'} &&
defined $self->{'_HASHREF'}->{$_});
}
$self->{'_UNTAGGED'};
}
################################ XEEN WRITE ################################
sub xeen_write {
my $self = shift;
return 1 unless defined $self->{'_OBJ'};
die unless $self->{'_MODE'} =~ /[+>]/;
my %argv = @_;
die unless defined $argv{'-hash'} && defined $argv{'-root'};
for (keys %{$argv{'-hash'}}) {
next unless defined $argv{'-hash'}->{$_};
$self->{'_HASHREF'}->{$_} =
xeen_tag $argv{'-root'}, \%{$argv{'-hash'}->{$_}};
$self->{'_UNTAGGED'}->{$_} = \%{$argv{'-hash'}->{$_}};
}
$self->{'_OBJ'}->sync;
}
################################ DESTRUCTOR ################################
sub DESTROY {
my $self = shift;
&{$self->{'_SUBS'}->{'destroy'}} ($self);
}
1;
__END__
=pod
=head1 NAME
C<DBM::DBass> - DBM with associative arrays, file locking and XML records
=head1 SYNOPSIS
use DBM::DBass;
die unless DBM::DBass::gestalt (-api => 'neo');
my $db = DBM::DBass->new (
-api => 'neo',
-file => '+<file.dbm',
-lock => 'file.lock',
-mode => 0644
);
=head1 DESCRIPTION
This module provides methods to read, write and delete associative arrays in
DBM files, with file locking and XML records.
It uses a named argument C<-api> for class methods C<new> and C<gestalt> to
try to prevent later versions of the module from breaking preexisting APIs.
=head1 METHODS
=over 4
=item C<gestalt>
This method checks for the existence of an API:
die 'no API neo' unless DBM::DBass::gestalt (-api => 'neo');
C<-api> is the calling API to check for. One should use this method only for
development or testing, and not in frequently used applications.
=item C<new>
This method creates a new DBass object, and should be the first one called:
my $db = DBM::DBass->new (
'-api' => 'neo',
'-file' => '+<file.dbm',
'-lock' => 'file.lock',
'-mode' => 0644
);
C<-api> is the calling API to use. C<-file> is the read/write mode (default
is read-only) and DBM filename. C<-lock> is the lock filename. C<-mode> is
the file permissions mode of the DBM file.
If the DBM file is opened for read-only access, the lock file must preexist,
but can be empty. In MacOS, one can create an empty file with SimpleText. In
*nix, one can create an empty file with C<touch>:
touch file.lock
This version of the module has APIs C<xeen> and X<neo>. The C<xeen> API is
deprecated and provided for backward compatibility only, and the C<neo> API
should be used when possible.
=item C<close>
This method releases various resources in the DBass object, to allow other
processes to access the DBM file:
$db->close;
Normally this method should not be used, as it renders the object useless for
the remainder of the program execution (and is automatically called when the
object is destroyed).
=item C<delete>
This method deletes records from the DBM file:
$db->delete ('-keys' => \@keys);
$db->delete ('-keys' => \%keys);
$db->delete ('-keys' => $key );
B<Be careful.> It can also delete all records:
$db->delete;
=item C<keys>
This method returns record keys:
my @keys = $db->keys;
=item C<read>
This method returns a hash reference pointing to records in the DBM file:
my $smallerhashref = $db->read ('-keys' => \@keys, '-root' => $root);
my $smallerhashref = $db->read ('-keys' => \%keys, '-root' => $root);
my $smallhashref = $db->read ('-keys' => $keys, '-root' => $root);
my $entirehashref = $db->read ('-root' => $root);
C<-keys> are the keys to match against. C<-root> is the XML root tag name
used in storing the records.
=item C<write>
This method writes key-value pairs to the DBM file:
$db->write (-hash => \%hash, -root => $root);
C<-hash> is the hash reference pointing to the key-value pairs (records).
C<-root> is the XML root tag name to use in storing the records.
=back
=head1 KNOWN ISSUES
The C<xeen> API is deprecated and provided for backward compatibility only,
and the C<neo> API should be used when possible. The main reason for the API
name change is that the C<neo> record format is significantly different from
that of C<xeen>.
On platforms other than MacOS, *nix or Windows NT, C<flock> will probably
cause the module to crash and burn.
The module should be pronounced C</di'bas/>.
The C<xeen> API is not named after the IBM alphaWorks C<Xeena> XML editor.
=head1 CHANGES
0.54 2000.01.19 renamed package to DBM::DBass, as per Tim Bunce
0.53 2000.01.11 fixed Makefile.PL (oops!)
0.52 1999.10.30 added check for _OBJ
added check for _HASHREF
fixed neo_read handling of _UNTAGGED
fixed neo_read to check for _HASHREF
fixed neo_write to check for _OBJ
fixed xeen_delete to check for _OBJ
fixed xeen_destroy to check for _OBJ
fixed xeen_new die preparation
fixed xeen_new to include _UNTAGGED
fixed xeen_read handling of _UNTAGGED
fixed xeen_read to check for _HASHREF
fixed xeen_write to check for _OBJ
0.51 1999.10.26 fixed gestalt for wantarray
fixed neo_read to accept hash references as -keys
fixed xeen_delete to accept hash references as -keys
fixed xeen_read to accept hash references as -keys
0.50 1999.10.06 added neo API (valid XML tags and lists of lists)
0.40 1999.09.20 fixed DBM file locking bug in xeen_destroy
fixed DBM file locking bug in xeen_new
fixed xeen_delete to accept scalars as -keys
fixed xeen_read to accept scalars as -keys
=head1 AUTHOR
Copyright 1999, 2000 Nguon Hao Ching (C<spiderboy@spiderboy.net>).
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=head1 CREDITS
Thanks to Tom Christiansen for Perl Cookbook recipe 14.5.
Thanks to Mark-Jason Dominus for the Perl Monger tutorial on file locking.
Thanks to David Harris and Paul Marquess for the recipe bug report.
Thanks to Chris Nandor for C<perlport>.
Thanks to James Wismer for feedback on the initial, unreleased version.
Thanks to Jay Trolley for her patience and understanding.
Thanks to xeenie for everything else.
=cut