Tying Hashes (Programming Perl)

14.3. Tying Hashes

A class implementing a tied hash should define eight methods. TIEHASH constructs new objects. FETCH and STORE access the key/value pairs. EXISTS reports whether a key is present in the hash, and DELETE removes a key along with its associated value.[2]CLEAR empties the hash by deleting all key/value pairs. FIRSTKEY and NEXTKEY iterate over the key/value pairs when you call keys, values, or each. And as usual, if you want to perform particular actions when the object is deallocated, you may define a DESTROY method. (If this seems like a lot of methods, you didn't read the last section on arrays attentively. In any event, feel free to inherit the default methods from the standard Tie::Hash module, redefining only the interesting ones. Again, Tie::StdHash assumes the implementation is also a hash.)

[2] Remember that Perl distinguishes between a key not existing in the hash and a key existing in the hash but having a corresponding value of undef. The two possibilities can be tested with exists and defined, respectively.

For example, suppose you want to create a hash where every time you assign a value to a key, instead of overwriting the previous contents, the new value is appended to an array of values. That way when you say:

$h{$k} = "one";
$h{$k} = "two";

It really does:

push @{ $h{$k} }, "one";
push @{ $h{$k} }, "two";

That's not a very complicated idea, so you should be able to use a pretty simple module. Using Tie::StdHash as a base class, it is. Here's a Tie::AppendHash that does just that:

package Tie::AppendHash;
use Tie::Hash;
our @ISA = ("Tie::StdHash");
sub STORE {
    my ($self, $key, $value) = @_;
    push @{$self->{key}}, $value;
}
1;

14.3.1. Hash-Tying Methods

Here's an example of an interesting tied-hash class: it gives you a hash representing a particular user's dot files (that is, files whose names begin with a period, which is a naming convention for initialization files under Unix). You index into the hash with the name of the file (minus the period) and get back that dot file's contents. For example:

use DotFiles;
tie %dot, "DotFiles";
if ( $dot{profile} =~ /MANPATH/ or
     $dot{login}   =~ /MANPATH/ or
     $dot{cshrc}   =~ /MANPATH/    ) {
    print "you seem to set your MANPATH\n";
}

Here's another way to use our tied class:

# Third argument is the name of a user whose dot files we will tie to.
tie %him, "DotFiles", "daemon";
foreach $f (keys %him) {
    printf "daemon dot file %s is size %d\n", $f, length $him{$f};
}

In our DotFiles example we implement the object as a regular hash containing several important fields, of which only the {CONTENTS} field will contain what the user thinks of as the hash. Here are the object's actual fields:

Field	Contents
`USER`	Whose dot files this object represents.
`HOME`	Where those dot files live.
`CLOBBER`	Whether we are allowed to change or remove those dot files.
`CONTENTS`	The hash of dot file names and content mappings.

Here's the start of DotFiles.pm:

package DotFiles;
use Carp;
sub whowasi { (caller(1))[3] . "()" }
my $DEBUG = 0;
sub debug { $DEBUG = @_ ? shift : 1 }

For our example, we want to be able to turn on debugging output to help in tracing during development, so we set up $DEBUG for that. We also keep one convenience function around internally to help print out warnings: whowasi returns the name of the function that called the current function (whowasi's "grandparent" function).

Here are the methods for the DotFiles tied hash:

CLASSNAME->TIEHASH(LIST)

Here's the DotFiles constructor:

sub TIEHASH {
    my $self   = shift;
    my $user   = shift || $>;
    my $dotdir = shift || "";

    croak "usage: @{[ &whowasi ]} [USER [DOTDIR]]" if @_;

    $user = getpwuid($user) if $user =~ /^\d+$/;
    my $dir = (getpwnam($user))[7]
            or croak "@{ [&whowasi] }: no user $user";
    $dir .= "/$dotdir" if $dotdir;

    my $node = {
        USER        => $user,
        HOME        => $dir,
        CONTENTS    => {},
        CLOBBER     => 0,
    };

    opendir DIR, $dir
            or croak "@{[&whowasi]}: can't opendir $dir: $!";
    for my $dot ( grep /^\./ && -f "$dir/$_", readdir(DIR)) {
        $dot =~ s/^\.//;
        $node->{CONTENTS}{$dot} = undef;
    }
    closedir DIR;

    return bless $node, $self;
}

It's probably worth mentioning that if you're going to apply file tests to the values returned by the above readdir, you'd better prepend the directory in question (as we do). Otherwise, since no chdir was done, you'd likely be testing the wrong file.

SELF->FETCH(KEY)

This method implements reading an element from the tied hash. It takes one argument after the object: the key whose value we're trying to fetch. The key is a string, and you can do anything you like with it (consistent with its being a string).

Here's the fetch for our DotFiles example:

sub FETCH {
    carp &whowasi if $DEBUG;
    my $self = shift;
    my $dot = shift;
    my $dir = $self->{HOME};
    my $file = "$dir/.$dot";

    unless (exists $self->{CONTENTS}->{$dot} || -f $file) {
        carp "@{[&whowasi]}: no $dot file" if $DEBUG;
        return undef;
    }

    # Implement a cache.
    if (defined $self->{CONTENTS}->{$dot}) {
        return $self->{CONTENTS}->{$dot};
    } else {
        return $self->{CONTENTS}->{$dot} = `cat $dir/.$dot`;
    }
}

We cheated a little by running the Unix cat(1) command, but it would be more portable (and more efficient) to open the file ourselves. On the other hand, since dotfiles are a Unixy concept, we're not that concerned. Or shouldn't be. Or something...

SELF->STORE(KEY, VALUE)

This method does the dirty work whenever an element in the tied hash is set (written). It takes two arguments after the object: the key under which we're storing the new value, and the value itself.

For our DotFiles example, we won't let users overwrite a file without first invoking the clobber method on the original object returned by tie:

sub STORE {
    carp &whowasi if $DEBUG;
    my $self  = shift;
    my $dot   = shift;
    my $value = shift;
    my $file  = $self->{HOME} . "/.$dot";

    croak "@{[&whowasi]}: $file not clobberable"
        unless $self->{CLOBBER};

    open(F, "> $file") or croak "can't open $file: $!";
    print F $value;
    close(F);
}

If someone wants to clobber something, they can say:

$ob = tie %daemon_dots, "daemon";
$ob->clobber(1);
$daemon_dots{signature} = "A true daemon\n";

But they could alternatively set {CLOBBER} with tied:

tie %daemon_dots, "DotFiles", "daemon";
tied(%daemon_dots)->clobber(1);

or as one statement:

(tie %daemon_dots, "DotFiles", "daemon")->clobber(1);

The clobber method is simply:

sub clobber {
    my $self = shift;
    $self->{CLOBBER} = @_ ? shift : 1;
}

SELF->DELETE(KEY)

This method handles requests to remove an element from the hash. If your emulated hash uses a real hash somewhere, you can just call the real delete. Again, we'll be careful to check whether the user really wants to clobber files:

sub DELETE   {
    carp &whowasi if $DEBUG;
    my $self = shift;
    my $dot = shift;
    my $file = $self->{HOME} . "/.$dot";
    croak "@{[&whowasi]}: won't remove file $file"
        unless $self->{CLOBBER};
    delete $self->{CONTENTS}->{$dot};
    unlink $file or carp "@{[&whowasi]}: can't unlink $file: $!";
}

SELF->CLEAR

This method is run when the whole hash needs to be cleared, usually by assigning the empty list to it. In our example, that would remove all the user's dot files! It's such a dangerous thing that we'll require CLOBBER to be set higher than 1 before this can happen:

sub CLEAR {
    carp &whowasi if $DEBUG;
    my $self = shift;
    croak "@{[&whowasi]}: won't remove all dotfiles for $self->{USER}"
        unless $self->{CLOBBER} > 1;
    for my $dot ( keys %{$self->{CONTENTS}}) {
        $self->DELETE($dot);
    }
}

SELF->EXISTS(KEY)

This method runs when the user invokes the exists function on a particular hash. In our example, we'll look at the {CONTENTS} hash element to find the answer:

sub EXISTS   {
    carp &whowasi if $DEBUG;
    my $self = shift;
    my $dot  = shift;
    return exists $self->{CONTENTS}->{$dot};
}

SELF->FIRSTKEY

This method is called when the user begins to iterate through the hash, such as with a keys, values, or each call. By calling keys in a scalar context, we reset its internal state to ensure that the next each used in the return statement will get the first key.

sub FIRSTKEY {
    carp &whowasi if $DEBUG;
    my $self = shift;
    my $temp = keys %{$self->{CONTENTS}};
    return scalar each %{$self->{CONTENTS}};
}

SELF->NEXTKEY(PREVKEY)

This method is the iterator for a keys, values, or each function. PREVKEY is the last key accessed, which Perl knows to supply. This is useful if the NEXTKEY method needs to know its previous state to calculate the next state.

For our example, we are using a real hash to represent the tied hash's data, except that this hash is stored in the hash's CONTENTS field instead of in the hash itself. So we can just rely on Perl's each iterator:

sub NEXTKEY  {
    carp &whowasi if $DEBUG;
    my $self = shift;
    return scalar each %{ $self->{CONTENTS} }
}

SELF->DESTROY

This method is triggered when a tied hash's object is about to be deallocated. You don't really need it except for debugging and extra cleanup. Here's a very simple version:

sub DESTROY  {
    carp &whowasi if $DEBUG;
}

Now that we've given you all those methods, your homework is to go back and find the places we interpolated @{[&whowasi]} and replace them with a simple tied scalar named $whowasi that does the same thing.