Lösung zu Blatt 7 --- UNIX Datenbanken II (WS 1999/2000)

8. Ein Interface für Hashes

package TBD::Hash;

use Carp;
use TBI;
use strict;
use vars qw(@ISA $VERSION);

$VERSION = "0.01";
@ISA = qw(TBI);

=head1 NAME

TBD::Hash - physical representation of tables as ordinary hashes

=head1 SYNOPSIS

use TBD::Hash;
@ISA = qw(... TBD::Hash ...);

=head1 DESCRIPTION

TBD::Hash provides loading and storing operations
for tables which are represented as ordinary hashes.
(as opposed to DBM files, NIS maps or database tables).

Following parameters are expected to be passed to constructors.
Modules which are derived from TBD::Hash are expected to pass these
parameters to TBD::Hash::initialize1.

=over 4

=item hash

The hash where the table is to be loaded from and to be stored to.

=item ifs

The input field separator which is to be given as regular expression.

=item ofs

The output field separator which is to be used on storing
modificated tables back to the hash.

=item tablename

A string specifying the table name.

=item keyfields

A pointer to a list of key field names.

=item fields

A pointer to a list of field names. The order must reflect the
order of fields in the input file.

=back

The parameters I<fields>, I<hash>, I<ifs>, and I<tablename>
are mandatory. Reasonable defaults are provided for I<keyfields>
(first field name of I<fields>), and I<ofs> (same as I<ifs>).

The registration of a set of hashes containing tables could
be arranged as in following example:

   my %table = (
      "Members" => {
         'ifs' => ':',
         'keyfields' => [qw(login)],
         'fields' => [qw(login name)],
      },
      "Documents" => {
         'ifs' => '~',
         'keyfields' => [qw(group shortname)],
         'fields' => [qw(group shortname login title)],
      },
      # ...
   );

   my %contents = (
      "A" => {
	 'borchert' => 'borchert:Andreas',
	 'grabert' => 'grabert:Matthias',
	 'melzer' => 'melzer:Ingo',
	 'swg' => 'swg:Franz',
      },
      "B" => {
	 '1~eins' => '1~eins~one~une',
	 '1~one' => '1~one~une~eins',
	 '2~zwei' => '2~zwei~two~deux',
	 '2~two' => '2~two~deux~zwei',
      },
   );

   foreach my $table (keys %table) {
      TBI->register($table, 'TBD::Hash', {
         'hash' => $contents{$table},
         'tablename' => $table,
         %{$table{$table}},
      });
   }

TBD::Hash provides exactly those methods required by TBI.

=head1 AUTHOR

=for html
<A HREF="http://www.mathematik.uni-ulm.de/sai/borchert/">Andreas Borchert</A>
and
<A HREF="http://www.mathematik.uni-ulm.de/sai/melzer/">Ingo Melzer</A>.

=for text
Andreas Borchert and Ingo Melzer.

=for man
Andreas Borchert and Ingo Melzer.

=cut

sub initialize1 {
   my ($self, %attributes) = @_;
   $self->SUPER::initialize1(%attributes);
   foreach my $field (qw(tablename hash fields ifs)) {
      croak "Undefined $field" unless defined $attributes{$field};
      $self->{$field} = $attributes{$field};
   }
   croak "Pointer to list of field names expected"
      unless ref($attributes{'fields'}) eq "ARRAY";
   croak "Hash expected" unless ref($attributes{'hash'}) eq "HASH";
   my %defaults = (
      'ofs' => $attributes{'ifs'},
      'keyfields' => [qw($attributes{'fields'}->[0])],
   );
   foreach my $field (keys %defaults) {
      if (defined $attributes{$field}) {
         $self->{$field} = $attributes{$field};
      } else {
         $self->{$field} = $defaults{$field};
      }
   }
}

sub initialize2 {
   my ($self) = @_;
   croak "Key fields not defined" unless ref($self->{'keyfields'});
   $self->{'valid_fieldnames'} = {};
   foreach my $field (@{$self->{'fields'}}) {
      ${$self->{'valid_fieldnames'}}{$field} = 1;
   }
   # check that all key field names are valid
   foreach my $keyfield (@{$self->{'keyfields'}}) {
      croak "Unknown field name: $keyfield"
	 unless defined($self->{'valid_fieldnames'}->{$keyfield});
   }
   $self->SUPER::initialize2();
}

sub fields {
   my $self = shift;
   return @{$self->{'fields'}};
}

sub keyfields {
   my $self = shift;
   return @{$self->{'keyfields'}};
}

sub close {
   my ($self) = @_;
   $self->SUPER::close();
}

sub _split_record {
   my ($self, $line) = @_;
   my %result = ();
   my @fields = split /$self->{'ifs'}/, $line;
   foreach my $fieldname (@{$self->{'fields'}}) {
      last if @fields == 0;
      $result{$fieldname} = shift @fields;
   }
   return %result;
}

sub _join_record {
   my ($self, %fields) = @_;
   return join($self->{'ofs'}, @fields{@{$self->{'fields'}}});
}

sub _mkkey {
   my ($self, $key) = @_;
   my @keyfields = $self->keyfields;
   if (@keyfields > 1) {
      croak "invalid key" if ref($key) ne "HASH";
   }
   if (ref($key) eq "HASH") {
      my %key = %{$key};
      $key = join($self->{'ofs'}, @key{@keyfields});
   }
   return $key;
}

sub fetch {
   my ($self, $key) = @_;
   my $hkey = $self->_mkkey($key);
   croak "no such key" unless defined $self->{'hash'}->{$hkey};
   return $self->_split_record($self->{'hash'}->{$hkey});
}

sub get {
   my ($self, $key, @fieldnames) = @_;
   my %record = $self->fetch($key);
   return @record{@fieldnames};
}

sub getfield {
   my ($self, $key, $fieldname) = @_;
   return scalar $self->get($key, $fieldname);
}

sub exists {
   my ($self, $key) = @_;
   my $hkey = $self->_mkkey($key);
   return exists $self->{'hash'}->{$hkey}; 
}

sub _genkeys {
   my ($self, @keys) = @_;
   my @keyfields = $self->keyfields;
   return @keys if @keyfields == 1;
   return map {
      do {
	 my %key = ();
	 my @fields = @keyfields;
	 foreach my $keyfield (split /$self->{'ifs'}/) {
	    $key{shift @fields} = $keyfield;
	 }
	 \%key;
      }
   } @keys;
}

sub keys {
   my $self = shift;
   return $self->_genkeys(keys %{$self->{'hash'}});
}

sub select {
   my ($self, %equations) = @_;
   if (%equations) {
      my @keys = ();
      my ($key, $fields);
      LOOP: while (($key, $fields) = each(%{$self->{'hash'}})) {
	 my %fields = $self->_split_record($fields);
	 foreach my $fieldname (keys %equations) {
	    next LOOP if $fields{$fieldname} ne $equations{$fieldname}
	 }
	 push(@keys, $key);
      }
      return $self->_genkeys(@keys);
   } else {
      # no equations given, so return all keys
      return $self->_genkeys(keys %{$self->{'hash'}});
   }
}

sub add {
   my ($self, $key, %fields) = @_;
   if (ref($key)) {
      %fields = (%fields, %{$key});
   } else {
      $fields{$self->{'keyfields'}->[0]} = $key;
   }
   my $hkey = $self->_mkkey($key);
   croak "key is already in use" if exists $self->{'hash'}->{$hkey};
   $self->{'hash'}->{$hkey} = $self->_join_record(%fields);
}

sub delete {
   my ($self, $key) = @_;
   my $hkey = $self->_mkkey($key);
   delete $self->{'hash'}->{$hkey};
}

sub modify {
   my ($self, $key, %fields) = @_;
   if (ref($key)) {
      %fields = (%fields, %{$key});
   } else {
      $fields{$self->{'keyfields'}->[0]} = $key;
   }
   my $hkey = $self->_mkkey($key);
   croak "invalid key" unless exists $self->{'hash'}->{$hkey};
   my %oldfields = $self->_split_record($self->{'hash'}->{$hkey});
   foreach my $fieldname (keys %oldfields) {
      $fields{$fieldname} = $oldfields{$fieldname}
	 unless exists $fields{$fieldname};
   }
   $self->{'hash'}->{$hkey} = $self->_join_record(%fields);
}

1;

Testdatei für lesenden Zugriff

#!/usr/local/bin/perl -w

use Test;
use strict;

BEGIN { plan tests => 15 }

use TBI;
use TBD::Hash;

my %table = (
   "A" => {
      'ifs' => ':',
      'keyfields' => [qw(a)],
      'fields' => [qw(a b c)],
   },
   "B" => {
      'ifs' => '~',
      'keyfields' => [qw(a b)],
      'fields' => [qw(a b c d)],
   },
);

my %contents = (
   "A" => {
      '1' => '1:foo:bar',
      '2' => '2:bar:foo',
      '3' => '3:ulm:koeln',
      '4' => '4:ulm:york',
   },
   "B" => {
      '1~eins' => '1~eins~one~une',
      '1~one' => '1~one~une~eins',
      '2~zwei' => '2~zwei~two~deux',
      '2~two' => '2~two~deux~zwei',
   },
);

foreach my $table (keys %table) {
   TBI->register($table, 'TBD::Hash', {
      'hash' => $contents{$table},
      'tablename' => $table,
      %{$table{$table}},
   });
}

my ($a, $b);
ok($a = TBI->open("A")); # 1
ok($b = TBI->open("B")); # 2

ok(join(":", $a->fields), "a:b:c"); # 3
ok(join(":", $a->keyfields), "a"); # 4
ok($a->name, "A"); # 5
ok($a->exists("1")); # 6
ok($a->exists("2")); # 7
ok($a->exists("3")); # 8
ok($a->exists("4")); # 9
ok(join(":", sort $a->keys), "1:2:3:4"); # 10
ok(sub { my %fields = $a->fetch("3"); $fields{'c'} }, "koeln"); # 11
ok(join(":", $a->get("2", qw(c b a))), "foo:bar:2"); # 12
ok(join(":", sort $a->select('b' => 'ulm')), "3:4"); # 13

ok(sub {
   my %fields = $b->fetch({'a' => '2', 'b' => 'zwei'});
   $fields{'c'}
}, "two"); # 14
ok(sub {
   my %fields = $b->fetch({'b' => 'zwei', 'a' => '2'});
   $fields{'d'}
}, "deux"); # 15

Testdatei für schreibenden Zugriff

#!/usr/local/bin/perl -w

use Test;
use strict;

BEGIN { plan tests => 7 }

use TBI;
use TBD::Hash;

my %table = (
   "A" => {
      'ifs' => ':',
      'keyfields' => [qw(a)],
      'fields' => [qw(a b c)],
   },
   "B" => {
      'ifs' => '~',
      'keyfields' => [qw(a b)],
      'fields' => [qw(a b c d)],
   },
);

my %contents = (
   "A" => {
      '1' => '1:foo:bar',
      '2' => '2:bar:foo',
      '3' => '3:ulm:koeln',
      '4' => '4:ulm:york',
   },
   "B" => {
      '1~eins' => '1~eins~one~une',
      '1~one' => '1~one~une~eins',
      '2~zwei' => '2~zwei~two~deux',
      '2~two' => '2~two~deux~zwei',
   },
);

foreach my $table (keys %table) {
   TBI->register($table, 'TBD::Hash', {
      'hash' => $contents{$table},
      'tablename' => $table,
      %{$table{$table}},
   });
}

my ($a, $b);
ok($a = TBI->open("A")); # 1
ok($b = TBI->open("B")); # 2

ok(sub {
   $a->modify('2', 'b' => 'foo');
   $a->getfield('2', 'b');
}, "foo"); # 3
ok(sub {
   $a->add('5', 'a' => '5', 'b' => 'ulm', 'c' => 'ssv');
   ($a->select('c' => 'ssv'))[0];
}, "5"); # 4
my @x = ($a->select('c' => 'ssv'));
ok(sub {
   $a->delete('3');
   !$a->exists('3');
}); # 5

ok($a->getfield('2', 'b'), "foo"); # 6
ok(($a->select('c' => 'ssv'))[0], "5"); # 7;