perl 5.002gamma: [patch introduction and re-organisations]

[ re-organisations:

# Give this module a sensible home.
mv pod/PerlDoc/Functions.pm lib/Pod/Functions.pm
rmdir pod/PerlDoc

# Tie:: finally has its own hierarchy
mkdir lib/Tie
mv lib/TieHash.pm lib/Tie/Hash.pm
mv lib/SubstrHash.pm lib/Tie/SubstrHash.pm

rm -f lib/FileHandle.pm    # Duplicate of ext/FileHandle/FileHandle.pm
rm -f os2/diff.MANIFEST    # Obsolete (I applied a variant of it.)
rm -f os2/diff.init        # Obsolete.

]

This is patch.2gamma to perl5.002 beta3.
This takes you from 5.002beta3 to 5.002gamma.

To apply this patch, run the above commands, then
cd to your perl source directory and then type

        patch -p1 -N < patch.2gamma

The changes are described after each /^Index/ line below.  This is
designed so you can examine each change with a command such as

        csplit -k patch.2gamma '/^Index:/' '{99}'

(Of course since there are 116 items and most csplit's have an
arbitrary limit of 100 files, you'll probably have to manually split
this file first, but you get the idea.  (GNU csplit doesn't have this
limitation.  Nor does a perl solution, of course.))

Patch and enjoy,

    Andy Dougherty              doughera@lafcol.lafayette.edu
    Dept. of Physics
    Lafayette College, Easton PA 18042

2 files changed, 297 insertions, 0 deletions

diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm
new file mode 100644
index 0000000000..161771a0ea
--- /dev/null
+++ b/lib/Tie/Hash.pm
@@ -0,0 +1,157 @@
+package TieHash;
+
+=head1 NAME
+
+TieHash, TieHash::Std - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+    package NewHash;
+    require TieHash;
+    
+    @ISA = (TieHash);
+    
+    sub DELETE { ... }		# Provides needed method
+    sub CLEAR { ... }		# Overrides inherited method
+    
+    
+    package NewStdHash;
+    require TieHash;
+    
+    @ISA = (TieHash::Std);
+    
+    # All methods provided by default, define only those needing overrides
+    sub DELETE { ... }
+    
+    
+    package main;
+    
+    tie %new_hash, NewHash;
+    tie %new_std_hash, NewStdHash;
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perlfunc/tie> for a list of the functions required in order to tie a hash
+to a package. The basic B<TieHash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<TieHash::Std> package
+provides most methods required for hashes in L<perlfunc/tie>. It inherits from
+B<TieHash>, and causes tied hashes to behave exactly like standard hashes,
+allowing for selective overloading of methods. The B<new> method is provided
+as grandfathering in the case a class forgets to include a B<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are:
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, class>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the (key, value) pair for the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next (key, value) pair for the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=back
+
+=head1 CAVEATS
+
+The L<perlfunc/tie> documentation includes a method called C<DESTROY> as
+a necessary method for tied hashes. Neither B<TieHash> nor B<TieHash::Std>
+define a default for this method.
+
+The C<CLEAR> method provided by these two packages is not listed in the
+L<perlfunc/tie> section.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implemetations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<TieHash>, they serve as
+good working examples.
+
+=cut
+    
+use Carp;
+
+sub new {
+    my $pkg = shift;
+    $pkg->TIEHASH(@_);
+}
+
+# Grandfather "new"
+
+sub TIEHASH {
+    my $pkg = shift;
+    if (defined &{"{$pkg}::new"}) {
+	carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"
+	    if $^W;
+	$pkg->new(@_);
+    }
+    else {
+	croak "$pkg doesn't define a TIEHASH method";
+    }
+}
+
+sub EXISTS {
+    my $pkg = ref $_[0];
+    croak "$pkg doesn't define an EXISTS method";
+}
+
+sub CLEAR {
+    my $self = shift;
+    my $key = $self->FIRSTKEY(@_);
+    my @keys;
+
+    while (defined $key) {
+	push @keys, $key;
+	$key = $self->NEXTKEY(@_, $key);
+    }
+    foreach $key (@keys) {
+	$self->DELETE(@_, $key);
+    }
+}
+
+# The TieHash::Std package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package TieHash::Std;
+@ISA = qw(TieHash);
+
+sub TIEHASH  { bless {}, $_[0] }
+sub STORE    { $_[0]->{$_[1]} = $_[2] }
+sub FETCH    { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY  { each %{$_[0]} }
+sub EXISTS   { exists $_[0]->{$_[1]} }
+sub DELETE   { delete $_[0]->{$_[1]} }
+sub CLEAR    { %{$_[0]} = () }
+
+1;
diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm
new file mode 100644
index 0000000000..6250e73848
--- /dev/null
+++ b/lib/Tie/SubstrHash.pm
@@ -0,0 +1,140 @@
+package SubstrHash;
+use Carp;
+
+sub TIEHASH {
+    my $pack = shift;
+    my ($klen, $vlen, $tsize) = @_;
+    my $rlen = 1 + $klen + $vlen;
+    $tsize = findprime($tsize * 1.1);	# Allow 10% empty.
+    $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+    $$self[0] x= $rlen * $tsize;
+    $self;
+}
+
+sub FETCH {
+    local($self,$key) = @_;
+    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+    &hashkey;
+    for (;;) {
+	$offset = $hash * $rlen;
+	$record = substr($$self[0], $offset, $rlen);
+	if (ord($record) == 0) {
+	    return undef;
+	}
+	elsif (ord($record) == 1) {
+	}
+	elsif (substr($record, 1, $klen) eq $key) {
+	    return substr($record, 1+$klen, $vlen);
+	}
+	&rehash;
+    }
+}
+
+sub STORE {
+    local($self,$key,$val) = @_;
+    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+    croak("Table is full") if $self[5] == $tsize;
+    croak(qq/Value "$val" is not $vlen characters long./)
+	if length($val) != $vlen;
+    my $writeoffset;
+
+    &hashkey;
+    for (;;) {
+	$offset = $hash * $rlen;
+	$record = substr($$self[0], $offset, $rlen);
+	if (ord($record) == 0) {
+	    $record = "\2". $key . $val;
+	    die "panic" unless length($record) == $rlen;
+	    $writeoffset = $offset unless defined $writeoffset;
+	    substr($$self[0], $writeoffset, $rlen) = $record;
+	    ++$$self[5];
+	    return;
+	}
+	elsif (ord($record) == 1) {
+	    $writeoffset = $offset unless defined $writeoffset;
+	}
+	elsif (substr($record, 1, $klen) eq $key) {
+	    $record = "\2". $key . $val;
+	    die "panic" unless length($record) == $rlen;
+	    substr($$self[0], $offset, $rlen) = $record;
+	    return;
+	}
+	&rehash;
+    }
+}
+
+sub DELETE {
+    local($self,$key) = @_;
+    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+    &hashkey;
+    for (;;) {
+	$offset = $hash * $rlen;
+	$record = substr($$self[0], $offset, $rlen);
+	if (ord($record) == 0) {
+	    return undef;
+	}
+	elsif (ord($record) == 1) {
+	}
+	elsif (substr($record, 1, $klen) eq $key) {
+	    substr($$self[0], $offset, 1) = "\1";
+	    return substr($record, 1+$klen, $vlen);
+	    --$$self[5];
+	}
+	&rehash;
+    }
+}
+
+sub FIRSTKEY {
+    local($self) = @_;
+    $$self[6] = -1;
+    &NEXTKEY;
+}
+
+sub NEXTKEY {
+    local($self) = @_;
+    local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+    for (++$iterix; $iterix < $tsize; ++$iterix) {
+	next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+	$$self[6] = $iterix;
+	return substr($$self[0], $iterix * $rlen + 1, $klen);
+    }
+    $$self[6] = -1;
+    undef;
+}
+
+sub hashkey {
+    croak(qq/Key "$key" is not $klen characters long.\n/)
+	if length($key) != $klen;
+    $hash = 2;
+    for (unpack('C*', $key)) {
+	$hash = $hash * 33 + $_;
+    }
+    $hash = $hash - int($hash / $tsize) * $tsize
+	if $hash >= $tsize;
+    $hash = 1 unless $hash;
+    $hashbase = $hash;
+}
+
+sub rehash {
+    $hash += $hashbase;
+    $hash -= $tsize if $hash >= $tsize;
+}
+
+sub findprime {
+    use integer;
+
+    my $num = shift;
+    $num++ unless $num % 2;
+
+    $max = int sqrt $num;
+
+  NUM:
+    for (;; $num += 2) {
+	for ($i = 3; $i <= $max; $i += 2) {
+	    next NUM unless $num % $i;
+	}
+	return $num;
+    }
+}
+
+1;