Acorn User 10/AU_CD10.iso/Updates/Perl/Non-RPC/!Perl/riscos/RDBM_File.pm

Text File | 1998-07-12 | 5KB | 163 lines

# By [e-mail]
# This is version 3: Mon 14th July 1997
# Requires gdbm module version 0.03 or later

package RDBM_File;
$debug = 0;

use RISCOS::SWI;
require Exporter;
require Tie::Hash;
@ISA = qw(Exporter Tie::Hash);
@EXPORT = qw(O_RDONLY  O_RDWR O_CREAT);
$VERSION = 0.04;

print "RDBM Loading\n" if $debug;

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

system('*rmensure gdbm 0.03 rmload system:modules.gdbm');
die("You need gdbm 0.03 or later") if `*rmensure gdbm 0.03 echo too old`;

# Get the SWI numbers
$Gdbm_Open = SWINumberFromString("XGdbm_Open");
$Gdbm_Store = SWINumberFromString("XGdbm_Store");
$Gdbm_Fetch = SWINumberFromString("XGdbm_Fetch");
$Gdbm_Exists = SWINumberFromString("XGdbm_Exists");
$Gdbm_Delete = SWINumberFromString("XGdbm_Delete");
$Gdbm_FirstKey = SWINumberFromString("XGdbm_FirstKey");
$Gdbm_NextKey = SWINumberFromString("XGdbm_NextKey");
$Gdbm_Clear = SWINumberFromString("XGdbm_Clear");
$Gdbm_Close = SWINumberFromString("XGdbm_Close");
$Gdbm_OpenIn = SWINumberFromString("XGdbm_OpenIn");

use Fcntl;

#Set up some register masks
$ocmask = ®mask([0]);
$sfmask = ®mask([0..4]);
$edmask = ®mask([0..2]);

#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], flags is $_[2], mode is $_[3],\n" if $debug;
    my ($pkg,$file,$flags) = @_; # Any mode parameter is ignored
    my $OpenSWI = ( $flags ) ? $Gdbm_Open : $Gdbm_OpenIn; # If $flags is 0, open for read only
    my ($pathname, $handle);
    my @path = split( m@\.@, $file);
    $file = pop(@path);
    if ( @path ) {
        $pathname = join('.', @path ).'.';
    } else {
        $pathname = $workdir;
    }
    $file = $pathname.$file;
        $handle = 0 + swix($OpenSWI,$ocmask,$file) if ( ( -e $file ) || ( $flags&O_CREAT ) );
    print "Handle is $handle\n" if $debug;
    return undef unless $handle;
    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);
    swi($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 = swi($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    return 0 if ($itemlen == -1);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = swi($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);
    swi($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 = swi($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    if ( $itemlen > $buflen ) {
        warn "Buffer extended" if $debug;
        $buffer = ' ' x $itemlen;
        $buflen = $itemlen;
        $itemlen = swi($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
    }
    swi($Gdbm_Delete,$edmask,$handle,$key,$keylen);
    return undef if ($itemlen == -1);
    substr($buffer, 0, $itemlen);
}

sub FIRSTKEY ($) {
    print "In FIRSTKEY, database ${$_[0]}\n " if $debug;
    my $handle = ${$_[0]};
    $itemlen = swi($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 = swi($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 = swi($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 = swi($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]};
    swi($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
    swi($Gdbm_Close,$ocmask,$handle);
}

1;

__END__