# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 30th Apr 1997
-# version 1.14
+# last modified 29th Jun 1997
+# version 1.15
#
# Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
croak ref($self) . " does not define the method ${method}" ;
}
-sub DESTROY { undef %{$_[0]} }
sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }
sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") }
sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") }
use Carp;
-$VERSION = "1.14" ;
+$VERSION = "1.15" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
}
-# import borrowed from IO::File
-# exports Fcntl constants if available.
-sub import {
- my $pkg = shift;
- my $callpkg = caller;
- Exporter::export $pkg, $callpkg, @_;
- eval {
- require Fcntl;
- Exporter::export 'Fcntl', $callpkg, '/^O_/';
- };
-}
+eval {
+ # Make all Fcntl O_XXX constants available for importing
+ require Fcntl;
+ my @O = grep /^O_/, @Fcntl::EXPORT;
+ Fcntl->import(@O); # first we import what we want to export
+ push(@EXPORT, @O);
+};
bootstrap DB_File $VERSION;
Made it illegal to tie an associative array to a RECNO database and an
ordinary array to a HASH or BTREE database.
+=item 1.15
+
+Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined
+value" warning with db_get and db_seq.
+
+Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the O_*
+constants from Fcntl.
+
+Removed the DESTROY method from the DB_File::HASHINFO module.
+
+Previously DB_File hard-wired the class name of any object that it
+created to "DB_File". This makes sub-classing difficult. Now DB_File
+creats objects in the namespace of the package it has been inherited
+into.
+
=back
=head1 BUGS
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 30th Apr 1997
- version 1.14
+ last modified 29th Jun 1997
+ version 1.15
All comments/suggestions/problems are welcome
1.13 - Tidied up a few casts.
1.14 - Made it illegal to tie an associative array to a RECNO
database and an ordinary array to a HASH or BTREE database.
+ 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
+ undefined value" warning with db_get and db_seq.
+
*/
#include "XSUB.h"
#include <db.h>
+/* #ifdef DB_VERSION_MAJOR */
+/* #include <db_185.h> */
+/* #endif */
#include <fcntl.h>
typedef DBT DBTKEY ;
-/* #define TRACE */
+/* #define TRACE */
#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
db_get(db, key, value, flags=0)
DB_File db
DBTKEY key
- DBT value
+ DBT value = NO_INIT
u_int flags
INIT:
CurrentDB = db ;
db_seq(db, key, value, flags)
DB_File db
DBTKEY key
- DBT value
+ DBT value = NO_INIT
u_int flags
INIT:
CurrentDB = db ;
OutputKey($arg, $var)
T_dbtdatum
OutputValue($arg, $var)
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
use DB_File;
use Fcntl;
-print "1..92\n";
+print "1..102\n";
sub ok
{
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos');
+ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
while (($key,$value) = each(%h)) {
$i++;
unlink $filename ;
}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(93, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+ ' ;
+
+ main::ok(94, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(95, $@ eq "") ;
+ main::ok(96, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(97, $@ eq "") ;
+ main::ok(98, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(99, $@ eq "" ) ;
+ main::ok(100, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(101, $@ eq "") ;
+ main::ok(102, $ret eq "[[11]]") ;
+
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
exit ;
use DB_File;
use Fcntl;
-print "1..52\n";
+print "1..62\n";
sub ok
{
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos');
+ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
while (($key,$value) = each(%h)) {
$i++;
unlink $filename ;
}
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(53, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
+ ' ;
+
+ main::ok(54, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(55, $@ eq "") ;
+ main::ok(56, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(57, $@ eq "") ;
+ main::ok(58, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(59, $@ eq "" ) ;
+ main::ok(60, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret eq "[[11]]") ;
+
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
+
exit ;
EOM
}
-print "1..56\n";
+print "1..66\n";
my $Dfile = "recno.tmp";
unlink $Dfile ;
my @h ;
ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
-ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
+ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640)
|| $^O eq 'amigaos') ;
#my $l = @h ;
unlink $Dfile;
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+}
+
+
{
# Check bval defaults to \n
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
- my $x = `cat $Dfile` ;
+ my $x = docat($Dfile) ;
unlink $Dfile;
ok(49, $x eq "abc\ndef\n\nghi\n") ;
}
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
- my $x = `cat $Dfile` ;
+ my $x = docat($Dfile) ;
unlink $Dfile;
my $ok = ($x eq "abc-def--ghi-") ;
bad_one() unless $ok ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
- my $x = `cat $Dfile` ;
+ my $x = docat($Dfile) ;
unlink $Dfile;
my $ok = ($x eq "abc def ghi ") ;
bad_one() unless $ok ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
- my $x = `cat $Dfile` ;
+ my $x = docat($Dfile) ;
unlink $Dfile;
my $ok = ($x eq "abc--def-------ghi--") ;
bad_one() unless $ok ;
unlink $filename ;
}
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(57, $@ eq "") ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+ ' ;
+
+ main::ok(58, $@ eq "") ;
+
+ my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
+ main::ok(59, $@ eq "") ;
+ main::ok(60, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(63, $@ eq "" ) ;
+ main::ok(64, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok(65, $@ eq "") ;
+ main::ok(66, $ret eq "[[11]]") ;
+
+ unlink "SubDB.pm", "recno.tmp" ;
+
+}
+
exit ;
projects / p5sagit/p5-mst-13.2.git / commitdiff