The Perl Ties That Bind

Like this article? We recommend

Writing CGI Applications with Perl

Learn More Buy

Like this article? We recommend

Like this article? We recommend 

Writing CGI Applications with Perl

Learn More Buy

Sample tie() Module

Now, on with our module! We'll create a module that ties to a password file for Apache, which means that there will be a file with entries like this:

'<name>:<encrypted password>'

There will also be a simple command-line script using the Example class. The script will let you enter names and passwords which will be stored in the password file through the magic of tie().

The start of the module is fairly uninteresting, aside from the fact that we're importing the group of file-locking constants from the Fcntl module. We do this because we want to use the system values for LOCK_EX, LOCK_SH, LOCK_UN, and LOCK_NB instead of assuming the operating system value for these.

package Example;

use strict;
use vars qw($VERSION);

# pull $VERSION from CVS version identifier
($VERSION = substr(q$Revision: 0.7 $, 10)) =~ s/\s+$//;

sub Version {return $VERSION;}

use Fcntl qw(:flock);

use Carp;

As explained earlier, the TIEHASH method is called implicitly when you invoke tie(). The first three lines tell our method the following:

• What the class object is, as well as the LIST elements passed during our invocation

• The file we're tying to

• The modes we're opening the file with

If the permission ($mode) argument isn't given, it defaults to 'r', read only. Or it can be given 'rw', which will allow for read and write operations. It's a good practice to add some sort of permission argument to a tie() class, to make sure that no one accidentally stores or removes information from the resource. It's also a good practice to have the default permission be the most restrictive.

Next, check to make sure that no extra arguments are passed to the module. If there are extra arguments, it croaks with a usage/syntax message.

Notice the scalar variable $clobber. Clobber is a term that tells the class whether the caller is able to make changes to the tied resource. It's directly affected by the permissions with which it was tied. If the mode is 'r', clobber is 0; for 'rw', clobber is 1. The $clobber variable will be used later to make sure that the file is opened with correct permissions, and deny changes to the file if it wasn't tie()'d with read-write permissions.

Next, an anonymous hash, %node, is built. This anonymous hash houses some instance data that will be referred to throughout the module. This hash contains the current settings of the path to the file, whether or not it can clobber, and the current hash values. The value of the current hash is held in memory because otherwise some later methods would have to open and read the file to build the hash again.

This allows for the current hash values to be in memory at all times. Speaking of which, the next few lines build that hash, and store it in the CURRENT field ($self->{CURRENT}).

You may choose to store the information from your resource in memory if the resource can be changed frequently only by your current process. If the application is used frequently by many users, each method should get the current data from the resource in some fashion. An alternative is to have a private method, which reads in the resources data. This method can then be called from within your class' methods to get the latest values. I suggest adding that functionality later, when playing around with the Example class.

Finally, the bless() function is called, which tells %node that it's now an object in the class. We're tied and ready to go!

# Create tied hash

sub TIEHASH {
    my $self = shift;
    my $path = shift;
    my $mode = shift || 'r';

    if (@_) {
        croak ("usage: tie(\%hash, \$file, [mode])");
    }

    my $clobber = ($mode eq 'rw' ? 1 : 0);

    my $node = {
        PATH  => $path,
        CLOBBER => $clobber,
        CURRENT => {}
    };

    open(FH, "$path");
        my @lines = <FH>;
    close FH;

    my ($line, $id, $pass);
    foreach $line (@lines) {
        ($id, $pass) = split(/\:/,$line);
        $node->{CURRENT}{$id} = $pass;
    }

    return bless $node => $self;
}

The next method to create is STORE. The STORE method handles the actual writing of data to the resource when a value in the tied hash changes. This method also performs any complex behavior that must be done before the data is written, such as encrypting a password.

This method is called when doing something such as the following:

$hash{FOO} = "bar";

The call above tells the class to store the value "bar" under key name FOO in %hash. This sets the name/value pairs in CURRENT and eventually in the password file. Since we're writing to an htpasswd-like password file, this STORE method also does the encryption (which can be considered hidden complex behavior).

The method begins by defining variables. If the call noted above were used, $id would be FOO, and $passwd would be "bar". It grabs the path, as well as checks for clobbering, from the class data that was saved in the constructor. If clobbering isn't allowed, it returns with an error message. For good programming measure, we're taking into account the fact that STORE is called after the upcoming method CLEAR finishes.

When STORE is called via CLEAR there will be no arguments (besides $self, of course). So STORE returns before writing an entry with no username or password.

# Store an entry

sub STORE {
    my $self = shift;
    my $id = shift;
    my $passwd = shift;
    my $passwdFile = $self->{PATH};
    my $return = 0;
    my @cache;
    my $cryptedPass;

    unless ($self->{CLOBBER}) {
        carp ("No write access for $self->{PATH}");
        return;
    }

    if (!$id && !$passwd) {
        return 1;
    }

The next step is to create the new encrypted password. The "salt" for encryption is obtained by getting the first two letters of the system's hostname by the hostname() method of the Sys::Hostname module (distributed with Perl). Before crypt() is called, we want to make sure that there's a password to crypt. There would be no password if the function is called intending to delete the password like this:

$hash{name} = "";
# or
$hash{name} = undef;

The method takes the situation of a blank password into account so that a username isn't written with no password. If there's a password, we encrypt it.

use Sys::Hostname;


my $salt = substr(hostname, 0, 2);

if ($passwd eq "") {
    $cryptedPass = "";
}else{
    $cryptedPass = crypt($passwd, $salt);
}

The new name/password pair is ready to be written to the password file. The file is opened and locked with flock() to make sure that the file isn't modified before the method finishes writing the new data. A check is made against the existing name/password pairs stored in memory to see whether there's already a password for this username. If the entry exists, the method runs through the file and replaces the old entry with the new one. If no such entry exists, the method appends the new entry to the file. Finally, it closes our file and adds the new entry into the hash in memory so the saved hash is in synch with the password file.

if (!open(FH,"{CURRENT}{Id}) {
    while (<FH>) {
        if ( /^$Id\:/ ) {
            push (@cache, "$Id\:$cryptedPass\n") unless $cryptedPass eq "";
            $return = 1; 
        } else {
            push (@cache, $_);
        }
    }
}
close FH;


if ($return) { 
    if (!open(FH, ">$passwdFile")) {
        carp("Cannot open $passwdFile: $!");
        return;
    }
    flock(FH, LOCK_EX);
    while (@cache) { 
        print FH shift (@cache); 
    }
}else{
    if (!open(FH, ">>$passwdFile")) {
        carp("Cannot open $passwdFile: $!");
        return;
    }
    flock(FH, LOCK_EX);
    print FH "$Id\:$cryptedPass\n" unless $cryptedPass eq "";
    $foo = $hash{FOO};
}

The FETCH method has a very specific function: to get a value. To do this it first checks whether the username ($Id) exists in the current hash. If so, it returns that value; if not, it returns a message saying that the username doesn't exist. The FETCH method is very simple and straightforward because it isn't performing any magic in the background.

sub FETCH {
    my $self = shift;
    my $Id = shift;     
    if (exists $self->{CURRENT}{$Id}) {
        return $self->{CURRENT}{$Id};
    }else{
        return "$Id doesn't exist";
    }
}

Here's a fast quiz. Judging by the names of the methods so far, what would you guess the method name is for deleting an entry in the file? (Faint sounds of the Jeopardy theme...) If you said DELETE, you're correct!

The DELETE method deletes an entry in the hash, and in turn the tied resource. It doesn't delete just the value, but the key/value pair. The DELETE method is only called when the delete() function is called. Assigning undef or "" to an entry in the hash doesn't delete that entry, so DELETE is not called.

delete $hash{FOO};

The above DELETE call deletes all instances of entry FOO. What you see in the example DELETE method should look familiar now. First a check for clobbering is done. If it's okay to clobber, a check is made in the local hash to make sure that the entry to be deleted actually exists. If it does, the file is opened and its entries are read, removing the entry marked for deletion. Finally, the new file is written. I added in a return of 1 when the entry doesn't exist, since the user may have thought that it did (I didn't think it warranted the script exiting). It also returns 1 when an entry is successfully deleted. The only error, aside from not being able to open a password file, that can make the subroutine die() is if the file was opened with read-only permissions.

sub DELETE {
    my $self = shift;
    my ($Id) = shift;
    my ($passwdFile) = $self->{PATH};
    my (@cache);

    unless ($self->{CLOBBER}) {
        carp ("No write access for $self->{PATH}");
        return;
    } 


    if (!exists $self->{CURRENT}{$Id}) {return 1;}

    delete $self->{CURRENT}{$Id};

    if (!open(FH,") {
            if ( /^$Id\:/ ) { 
                next;
            } else {
                push (@cache, $_);
            }
        }
    close FH;

    if (!open(FH,">$passwdFile")) {
        carp("Cannot open $passwdFile: $!");
        return;
    }
    flock(FH, LOCK_EX);
        while (@cache) {
            print FH shift (@cache); 
        }
    close FH;
    return 1;
}

The module is almost complete. Our next method, CLEAR, clears the entire hash, as well as clearing all the data out of the tied resource. CLEAR is generally called when you assign an empty list as the value of your tied hash. This occurs when assigning a null string to another hash, or undef. This can be very dangerous in a situation where a programmer isn't paying attention and makes a call to invoke CLEAR by accident. The following illustrates ways in which CLEAR will be invoked:

%hash = "";
%hash = %newHash;
%hash = {};
undef %hash;

To help prevent this sort of mishap, the module can be made more foolproof by adding another level of 'mode' to tie()—one that will set the $clobber variable to something higher than 1 (such as 2). Then the TIE* method can be written to understand not only 'r' and 'rw', but something like 'rwe' as well. This way, an extra level of security is added, and the user knows that he can erase the resource because he used the proper permissions when he invoked the tie(). I didn't add that into this example, but left it as an exercise for the reader. The example's CLEAR method will CLEAR the local hash, as well as the password file.

sub CLEAR {
    my $self = shift;
    my ($passwdFile) = $self->{PATH};

    unless ($self->{CLOBBER}) {
        carp ("No write access for $self->{PATH}");
        return;
    }

    if (!open(FH,">$passwdFile")) {
        carp("Cannot open $passwdFile: $!");
        return;
    }
    close FH;
    $self->{CURRENT} = {};
}

Now we get into the last few methods. These are very simple methods, and very short! The FIRSTKEY method is invoked when a call is made to iterate through the hash, generally with the keys() or each() functions.

sub FIRSTKEY {
    my $self = shift; 
    my $a = keys %{$self->{CURRENT}};
    each %{$self->{CURRENT}};
}

One of the last methods is NEXTKEY. This method is also invoked during an each() or keys() iteration. Behind the scenes it is given two arguments, 'this' and 'lastkey', which are the object and the last key iterated through, respectively. It's very similar to FIRSTKEY but it returns all the keys, as opposed to the first key in the hash. Arguments are ignored because the method is using the each function behind the scenes to iterate over the $self->{CURRENT} hash.

sub NEXTKEY {
my $self = shift;
   return each %{$self->{CURRENT}};

}

The last method is the class destructor, DESTROY. This method is invoked when the tied variable is to be destroyed. Unless the return value of tie() has been saved, this can be done with the untie() function. If the tied variable hasn't been untie()'d, DESTROY is called when the script exits. In general, you don't need to have anything in a DESTROY method, unless you're doing some special debugging or you want to do some cleanup. In fact, you don't need to have a DESTROY method at all, and our Example.pm won't have this method.

Suppose you created a temp file for whatever reason, and want to delete it only when you know the tie() is finished. The line below would do that:

sub DESTROY { unlink "/tmp/tie.txt";}

And there you have it! A module that will bind a variable from a script to a password (or whatever) file. Now that it's written, let's use it. This is a quick command-line program to test this module. Try adding, deleting, and getting passwords.

#!/usr/bin/perl
use Example;

tie(%hash, "Example", "example", "rw") || die "Can't tie : $!";

&ask;

sub ask {
    print "(A)dd, (D)elete, or (G)et user:";
    $ans = <STDIN>;
    if ($ans =~ /a/i) { &add; }
    elsif ($ans =~ /d/i) { &delete;} 
    elsif ($ans =~ /g/i) {&get;}
    else { print "Try again\n"; &ask;}
}

sub add {
    print "User Name:";
    $name = <STDIN>;
    print "\nPassword:";
    $pass = <STDIN>;
    chop $name;
    chop $pass;
    $hash{$name} = $pass;
    print "\nAdded\nAgain (Y/N)?";
    $again = <STDIN>;
    if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}

}

sub delete {
    print "User Name:";
    $name = <STDIN>;
    chop $name;
    delete $hash{$name};
    print "\nDeleted\nAgain (Y/N)?";
    $again = <STDIN>;
    if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}

}

sub get {
    print "User Name:";
    $name = <STDIN>;
    chop $name;
    if (!exists $hash{$name}) {
        print "$name isn't valid";
    }else{
        print "$name\'s encrypted password is " . $hash{$name};
    }
    print "\nAgain (Y/N)?";
    $again = <STDIN>;
    if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}

}