ARM Club 3/TheARMClub_PDCD3.iso/hensa/hypertext/latex2html_1/!Perl_riscos_pm_RDBM_File

Text File | 1996-07-17 | 4.6 KB | 153 lines

#By [e-mail]
#This is version 2: Wed 17th July 1996

package RDBM_File;
use Carp;
use RiscosLib;

$debug = 0;

printf "RDBM Loading\n" if $debug;

%lastkey = ();
$buffer = ' 'x255;
$buflen = length($buffer);

system('rmensure gdbm 0 rmload system:modules.gdbm');

# Get the SWI numbers
$str="Gdbm_Open"; $Gdbm_Open = SWINumberFromString($str);
$str="Gdbm_Store";$Gdbm_Store = SWINumberFromString($str);
$str="Gdbm_Fetch";$Gdbm_Fetch = SWINumberFromString($str);
$str="Gdbm_Exists";$Gdbm_Exists = SWINumberFromString($str);
$str="Gdbm_Delete";$Gdbm_Delete = SWINumberFromString($str);
$str="Gdbm_FirstKey";$Gdbm_FirstKey = SWINumberFromString($str);
$str="Gdbm_NextKey";$Gdbm_NextKey = SWINumberFromString($str);
$str="Gdbm_Clear";$Gdbm_Clear = SWINumberFromString($str);
$str="Gdbm_Close";$Gdbm_Close = SWINumberFromString($str);

#Set up some register masks
@in = (0);@out = ();$ocmask = ®mask(\@in,\@out);
@in = (0..4);@out = ();$sfmask = ®mask(\@in,\@out);
@in = (0..2);@out = ();$edmask = ®mask(\@in,\@out);

#Set up a default work directory
$workdir = '<PerlArchLib$Dir>.work.rdbm.'; # Directory used if no pathname for the database

print "RDBM initialisation completed\n" if $debug;

sub TIEHASH  {
    print "In TIEHASH, package is $_[0], database is $_[1]\n" if $debug;
    my $file = $_[1];
    my $pathname;
    my @path = split( m@\.@, $file);
    $file = pop(@path);
    if ( @path ) {
        $pathname = join('.', @path ).'.';
    } else {
        $pathname = $workdir;
    }
    $file = $pathname.$file;
        my $handle = syscall($Gdbm_Open,$ocmask,$file) || croak ("Can't open database $file");
    my $self = \$handle;
    bless $self;
}

sub STORE    {
    print "In STORE, storing in database ${$_[0]}:\-   $_[1] : $_[2]\n" if $debug;
    my $handle = ${$_[0]};
    my $key = $_[1]; my $keylen = length($key);
    my $value = $_[2];
    $value = "$value"; # Force it to be a string
    my $vallen = length($value);
    syscall($Gdbm_Store,$sfmask,$handle,$key,$keylen,$value,$vallen);
}

sub FETCH    {
    print "In FETCH, finding value for $_[1] in database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    my $key = $_[1]; my $keylen = length($key);
    my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
#    carp("No such item") if ($itemlen == -1); #This is the old version
    return undef if ($itemlen == -1);
#    return 0 if ($itemlen == -1);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    }
    substr($buffer, 0, $itemlen);
}

sub EXISTS   {
    print "In EXISTS, finding value for $_[1] in database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    my $key = $_[1]; my $keylen = length($key);
    syscall($Gdbm_Exists,$edmask,$handle,$key,$keylen);
}

sub DELETE   {
    print "In DELETE, deleting value for $_[1] in database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    my $key = $_[1]; my $keylen = length($key);
    # DELETE should return deleted value, so we have to fetch it
    my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    carp("No such item") if ($itemlen == -1);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    }
    syscall($Gdbm_Delete,$edmask,$handle,$key,$keylen);
    substr($buffer, 0, $itemlen);
}

sub FIRSTKEY {
    print "In FIRSTKEY, database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    $itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
    return undef if ($itemlen == -1);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
    }
    $lastkey{$handle} = substr($buffer, 0, $itemlen);
}

sub NEXTKEY  {
    print "In NEXTTKEY, database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    my $key = $lastkey{$handle}; my $keylen = length($key);
    $itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    return undef if ($itemlen == -1);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    }
    $lastkey{$handle} = substr($buffer, 0, $itemlen);
}

sub CLEAR    {
    print "In CLEAR, database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    syscall($Gdbm_Clear,$ocmask,$handle);
}

sub DESTROY    {
    print "DESTROY called for ${$_[0]}\n" if $debug;
    my $handle = ${$_[0]};
    # I don't think we want actually to delete the database, just close it
    syscall($Gdbm_Close,$ocmask,$handle);
}

1;

__END__