# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 4th Sept 1996
-# version 1.03
+# last modified 10th Nov 1996
+# version 1.05
package DB_File::HASHINFO ;
+require 5.003 ;
+
use strict;
use Carp;
require Tie::Hash;
bless \%x, $pkg ;
}
+
sub TIEHASH
{
my $pkg = shift ;
- bless { 'bsize' => undef,
- 'ffactor' => undef,
- 'nelem' => undef,
- 'cachesize' => undef,
+ bless { 'bsize' => 0,
+ 'ffactor' => 0,
+ 'nelem' => 0,
+ 'cachesize' => 0,
'hash' => undef,
- 'lorder' => undef,
+ 'lorder' => 0,
}, $pkg ;
}
+
sub FETCH
{
my $self = shift ;
{
my $pkg = shift ;
- bless { 'bval' => undef,
- 'cachesize' => undef,
- 'psize' => undef,
- 'flags' => undef,
- 'lorder' => undef,
- 'reclen' => undef,
+ bless { 'bval' => 0,
+ 'cachesize' => 0,
+ 'psize' => 0,
+ 'flags' => 0,
+ 'lorder' => 0,
+ 'reclen' => 0,
'bfname' => "",
}, $pkg ;
}
{
my $pkg = shift ;
- bless { 'flags' => undef,
- 'cachesize' => undef,
- 'maxkeypage' => undef,
- 'minkeypage' => undef,
- 'psize' => undef,
+ bless { 'flags' => 0,
+ 'cachesize' => 0,
+ 'maxkeypage' => 0,
+ 'minkeypage' => 0,
+ 'psize' => 0,
'compare' => undef,
'prefix' => undef,
- 'lorder' => undef,
+ 'lorder' => 0,
}, $pkg ;
}
use Carp;
-$VERSION = "1.03" ;
+$VERSION = "1.05" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
-#$DB_BTREE = TIEHASH DB_File::BTREEINFO ;
-#$DB_HASH = TIEHASH DB_File::HASHINFO ;
-#$DB_RECNO = TIEHASH DB_File::RECNOINFO ;
-
$DB_BTREE = new DB_File::BTREEINFO ;
$DB_HASH = new DB_File::HASHINFO ;
$DB_RECNO = new DB_File::RECNOINFO ;
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
+sub TIEHASH
+{
+ my (@arg) = @_ ;
+
+ $arg[4] = tied %{ $arg[4] }
+ if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
+
+ DoTie_(@arg) ;
+}
+
+*TIEARRAY = \&TIEHASH ;
sub get_dup
{
my $counter = 0 ;
my $status = 0 ;
- # get the first value associated with the key, $key
- #$db->seq($key, $value, R_CURSOR()) ;
-
# iterate through the database until either EOF ($status == 0)
# or a different key is encountered ($key ne $origkey).
for ($status = $db->seq($key, $value, R_CURSOR()) ;
=head1 SYNOPSIS
use DB_File ;
- use strict 'untie' ;
[$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ;
[$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ;
database, delete keys/value pairs and finally how to enumerate the
contents of the database.
+ use strict ;
use DB_File ;
- use strict 'untie' ;
+ use vars qw( %h $k $v ) ;
tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
or die "Cannot open file 'fruit': $!\n";
BTREE uses. Instead of using the normal lexical ordering, a case
insensitive compare function will be used.
+ use strict ;
use DB_File ;
- use strict 'untie' ;
+
+ my %h ;
sub Compare
{
want to manipulate a BTREE database with duplicate keys. Consider this
code:
+ use strict ;
use DB_File ;
- use strict 'untie' ;
-
+
+ use vars qw($filename %h ) ;
+
$filename = "tree" ;
unlink $filename ;
Here is the script above rewritten using the C<seq> API method.
+ use strict ;
use DB_File ;
- use strict 'untie' ;
+ use vars qw($filename $x %h $status $key $value) ;
+
$filename = "tree" ;
unlink $filename ;
# iterate through the btree using seq
# and print each key/value pair.
+ $key = $value = 0 ;
for ($status = $x->seq($key, $value, R_FIRST) ;
$status == 0 ;
$status = $x->seq($key, $value, R_NEXT) )
So assuming the database created above, we can use C<get_dup> like
this:
- $cnt = $x->get_dup("Wall") ;
+ my $cnt = $x->get_dup("Wall") ;
print "Wall occurred $cnt times\n" ;
- %hash = $x->get_dup("Wall", 1) ;
+ my %hash = $x->get_dup("Wall", 1) ;
print "Larry is there\n" if $hash{'Larry'} ;
print "There are $hash{'Brick'} Brick Walls\n" ;
- @list = $x->get_dup("Wall") ;
+ my @list = $x->get_dup("Wall") ;
print "Wall => [@list]\n" ;
@list = $x->get_dup("Smith") ;
Here is the relevant quote from the dbopen man page where it defines
the use of the R_CURSOR flag with seq:
-
Note, for the DB_BTREE access method, the returned key is not
necessarily an exact match for the specified key. The returned key
is the smallest key greater than or equal to the specified key,
permitting partial key matches and range searches.
-
In the example script below, the C<match> sub uses this feature to find
and print the first matching key/value pair given a partial key.
+ use strict ;
use DB_File ;
use Fcntl ;
- use strict 'untie' ;
+
+ use vars qw($filename $x %h $st $key $value) ;
sub match
{
my $key = shift ;
- my $value ;
+ my $value = 0;
my $orig_key = $key ;
$x->seq($key, $value, R_CURSOR) ;
print "$orig_key\t-> $key\t-> $value\n" ;
$h{'Smith'} = 'John' ;
+ $key = $value = 0 ;
print "IN ORDER\n" ;
for ($st = $x->seq($key, $value, R_FIRST) ;
$st == 0 ;
Here is a simple example that uses RECNO.
+ use strict ;
use DB_File ;
- use strict 'untie' ;
+ my @h ;
tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO
or die "Cannot open file 'text': $!\n" ;
# same again, but use the API functions instead
print "\nREVERSE again\n" ;
- my ($s, $k, $v) ;
+ my ($s, $k, $v) = (0, 0, 0) ;
for ($s = $H->seq($k, $v, R_LAST) ;
$s == 0 ;
$s = $H->seq($k, $v, R_PREV))
B<Important:> If you have saved a copy of the object returned from
C<tie>, the underlying database file will I<not> be closed until both
the tied variable is untied and all copies of the saved object are
-destroyed. See L<The strict untie pragma> for more details.
+destroyed.
use DB_File ;
$db = tie %hash, "DB_File", "filename"
=head1 HINTS AND TIPS
-=head2 The strict untie pragma
-
-If you run Perl version 5.004 or later (actually any version from the
-5.003_01 development release on will suffice) and you make use of the
-Berkeley DB API, it is is I<very> strongly recommended that you always
-include the C<use strict 'untie'> pragma in any of your scripts that
-make use of B<DB_File>.
-
-Even if you don't currently make use of the API interface, it is still
-a good idea to include the pragma. It won't affect the performance of
-your script, but it will prevent problems in the future.
-
-If possible you should try to run with the full strict pragma, but that
-is another story. For further details see L<strict> and
-L<perldsc/WHY YOU SHOULD ALWAYS C<use strict>>.
-
-To illustrate the importance of including the untie pragma, here is an
-example script that fails in an unexpected place because it doesn't use
-it:
-
- use DB_File ;
- use Fcntl ;
-
- $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
- or die "Cannot tie first time: $!" ;
-
- $x{123} = 456 ;
-
- untie %x ;
-
- $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
- or die "Cannot tie second time: $!" ;
-
- untie %x ;
-
-When run the script will produce this error message:
-
- Cannot tie second time: Invalid argument at bad.file line 12.
-
-Although the error message above refers to the second tie statement in
-the script, the source of the problem is really with the untie
-statement that precedes it.
-
-To understand why there is a problem at all with the untie statement,
-consider what the tie does for a moment.
-
-Whenever the tie is executed, it creates a logical link between a Perl
-variable, the associative array C<%x> in this case, and a Berkeley DB
-database, C<tst.fil>. The logical link ensures that all operation on
-the associative array are automatically mirrored to the database file.
-
-In normal circumstances the untie is enough to break the logical link
-and also close the database. In this particular case there is another
-logical link, namely the API object returned from the tie and stored in
-C<$X>. Whenever the untie is executed in this case, only the link
-between the associative array and the database will be broken. The API
-object in C<$X> is still valid, so the database will not be closed.
-
-The end result of this is that when the second tie is executed, the
-database will be in an inconsistent state (i.e. it is still opened by
-the first tie) - thus the second tie will fail.
-
-If the C<use strict 'untie'> pragma is included in the script, like
-this:
-
- use DB_File ;
- use Fcntl ;
- use strict 'untie' ;
-
- $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
- or die "Cannot tie first time: $!" ;
-
- $x{123} = 456 ;
-
- untie %x ;
-
- $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
- or die "Cannot tie second time: $!" ;
-
-then the error message becomes:
-
- Can't untie: 1 inner references still exist at bad.file line 11.
-
-which pinpoints the real problem. Finally the script can now be
-modified to fix the original problem by destroying the API object
-before the untie:
-
- ...
- $x{123} = 456 ;
-
- undef $X ;
- untie %x ;
-
- $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
- ...
=head2 Locking Databases
open() to give something Perl will flock() for you. Run this repeatedly
in the background to watch the locks granted in proper order.
- use strict 'untie';
use DB_File;
use strict;
print "$$: Write lock granted\n";
$db{$key} = $value;
- $db->sync;
+ $db->sync; # to flush
sleep 10;
flock(DB_FH, LOCK_UN);
I<ggh> script (available from your nearest CPAN archive in
F<authors/id/TOMC/scripts/nshist.gz>).
+ use strict ;
use DB_File ;
use Fcntl ;
- use strict 'untie' ;
+ use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
$dotdir = $ENV{HOME} || $ENV{LOGNAME};
$HISTORY = "$dotdir/.netscape/history.db";
=item 1.
-Attempting to reopen a database without closing it. See
-L<The strict untie pragma> for an example.
+Attempting to reopen a database without closing it.
=item 2.
Modified the behavior of get_dup. When it returns an associative
array, the value is the count of the number of matching BTREE values.
+=item 1.04
+
+Minor documentation changes.
+
+Fixed a bug in hash_cb. Patches supplied by Dave Hammen,
+E<lt>hammen@gothamcity.jsc.nasa.govE<gt>.
+
+Fixed a bug with the constructors for DB_File::HASHINFO,
+DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the
+constructors to make them C<-w> clean.
+
+Reworked part of the test harness to be more locale friendly.
+
+=item 1.05
+
+Made all scripts in the documentation C<strict> and C<-w> clean.
+
+Added logic to F<DB_File.xs> to allow the module to be built after Perl
+is installed.
+
+=back
+
=head1 BUGS
Some older versions of Berkeley DB had problems with fixed length
Berkeley DB is available at your nearest CPAN archive (see
L<perlmod/"CPAN"> for a list) in F<src/misc/db.1.85.tar.gz>, or via the
-host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. It is I<not> under
-the GPL.
+host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. Alternatively,
+check out the Berkeley DB home page at F<http://www.bostic.com/db>. It
+is I<not> under the GPL.
If you are running IRIX, then get Berkeley DB from
F<http://reality.sgi.com/ariel>. It has the patches necessary to
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 4th Sept 1996
- version 1.03
+ last modified 10th Nov 1996
+ version 1.05
All comments/suggestions/problems are welcome
Allow negative subscripts with RECNO interface.
Changed the default flags to O_CREAT|O_RDWR
1.03 - Added EXISTS
+ 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
+ Dave Hammen, hammen@gothamcity.jsc.nasa.gov
+ 1.05 - Added logic to allow prefix & hash types to be specified via
+ Makefile.PL
*/
#include <fcntl.h>
+#ifdef mDB_Prefix_t
+#ifdef DB_Prefix_t
+#undef DB_Prefix_t
+#endif
+#define DB_Prefix_t mDB_Prefix_t
+#endif
+
+#ifdef mDB_Hash_t
+#ifdef DB_Hash_t
+#undef DB_Hash_t
+#endif
+#define DB_Hash_t mDB_Hash_t
+#endif
+
+union INFO {
+ HASHINFO hash ;
+ RECNOINFO recno ;
+ BTREEINFO btree ;
+ } ;
+
typedef struct {
DBTYPE type ;
DB * dbp ;
SV * compare ;
SV * prefix ;
SV * hash ;
+ union INFO info ;
} DB_File_type;
typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;
-union INFO {
- HASHINFO hash ;
- RECNOINFO recno ;
- BTREEINFO btree ;
- } ;
-
-/* #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)
if (size == 0)
data = "" ;
+ /* DGH - Next two lines added to fix corrupted stack problem */
+ ENTER ;
+ SAVETMPS;
+
PUSHMARK(sp) ;
+
XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
PUTBACK ;
static void
PrintHash(hash)
-HASHINFO hash ;
+HASHINFO * hash ;
{
printf ("HASH Info\n") ;
- printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
- printf (" bsize = %d\n", hash.bsize) ;
- printf (" ffactor = %d\n", hash.ffactor) ;
- printf (" nelem = %d\n", hash.nelem) ;
- printf (" cachesize = %d\n", hash.cachesize) ;
- printf (" lorder = %d\n", hash.lorder) ;
+ printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
+ printf (" bsize = %d\n", hash->bsize) ;
+ printf (" ffactor = %d\n", hash->ffactor) ;
+ printf (" nelem = %d\n", hash->nelem) ;
+ printf (" cachesize = %d\n", hash->cachesize) ;
+ printf (" lorder = %d\n", hash->lorder) ;
}
static void
PrintRecno(recno)
-RECNOINFO recno ;
+RECNOINFO * recno ;
{
printf ("RECNO Info\n") ;
- printf (" flags = %d\n", recno.flags) ;
- printf (" cachesize = %d\n", recno.cachesize) ;
- printf (" psize = %d\n", recno.psize) ;
- printf (" lorder = %d\n", recno.lorder) ;
- printf (" reclen = %d\n", recno.reclen) ;
- printf (" bval = %d\n", recno.bval) ;
- printf (" bfname = %d [%s]\n", recno.bfname, recno.bfname) ;
+ printf (" flags = %d\n", recno->flags) ;
+ printf (" cachesize = %d\n", recno->cachesize) ;
+ printf (" psize = %d\n", recno->psize) ;
+ printf (" lorder = %d\n", recno->lorder) ;
+ printf (" reclen = %d\n", recno->reclen) ;
+ printf (" bval = %d\n", recno->bval) ;
+ printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
}
PrintBtree(btree)
-BTREEINFO btree ;
+BTREEINFO * btree ;
{
printf ("BTREE Info\n") ;
- printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ;
- printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ;
- printf (" flags = %d\n", btree.flags) ;
- printf (" cachesize = %d\n", btree.cachesize) ;
- printf (" psize = %d\n", btree.psize) ;
- printf (" maxkeypage = %d\n", btree.maxkeypage) ;
- printf (" minkeypage = %d\n", btree.minkeypage) ;
- printf (" lorder = %d\n", btree.lorder) ;
+ printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
+ printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
+ printf (" flags = %d\n", btree->flags) ;
+ printf (" cachesize = %d\n", btree->cachesize) ;
+ printf (" psize = %d\n", btree->psize) ;
+ printf (" maxkeypage = %d\n", btree->maxkeypage) ;
+ printf (" minkeypage = %d\n", btree->minkeypage) ;
+ printf (" lorder = %d\n", btree->lorder) ;
}
#else
}
static DB_File
-ParseOpenInfo(name, flags, mode, sv, string)
+ParseOpenInfo(name, flags, mode, sv)
char * name ;
int flags ;
int mode ;
SV * sv ;
-char * string ;
{
SV ** svp;
HV * action ;
- union INFO info ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
+ union INFO * info = &RETVAL->info ;
/* Default to HASH */
RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
RETVAL->type = DB_HASH ;
+ /* DGH - Next line added to avoid SEGV on existing hash DB */
+ CurrentDB = RETVAL;
+
if (sv)
{
if (! SvROK(sv) )
croak ("type parameter is not a reference") ;
action = (HV*)SvRV(sv);
+
if (sv_isa(sv, "DB_File::HASHINFO"))
{
RETVAL->type = DB_HASH ;
- openinfo = (void*)&info ;
+ openinfo = (void*)info ;
svp = hv_fetch(action, "hash", 4, FALSE);
if (svp && SvOK(*svp))
{
- info.hash.hash = hash_cb ;
+ info->hash.hash = hash_cb ;
RETVAL->hash = newSVsv(*svp) ;
}
else
- info.hash.hash = NULL ;
+ info->hash.hash = NULL ;
svp = hv_fetch(action, "bsize", 5, FALSE);
- info.hash.bsize = svp ? SvIV(*svp) : 0;
+ info->hash.bsize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "ffactor", 7, FALSE);
- info.hash.ffactor = svp ? SvIV(*svp) : 0;
+ info->hash.ffactor = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "nelem", 5, FALSE);
- info.hash.nelem = svp ? SvIV(*svp) : 0;
+ info->hash.nelem = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.hash.cachesize = svp ? SvIV(*svp) : 0;
+ info->hash.cachesize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.hash.lorder = svp ? SvIV(*svp) : 0;
+ info->hash.lorder = svp ? SvIV(*svp) : 0;
PrintHash(info) ;
}
else if (sv_isa(sv, "DB_File::BTREEINFO"))
{
RETVAL->type = DB_BTREE ;
- openinfo = (void*)&info ;
+ openinfo = (void*)info ;
svp = hv_fetch(action, "compare", 7, FALSE);
if (svp && SvOK(*svp))
{
- info.btree.compare = btree_compare ;
+ info->btree.compare = btree_compare ;
RETVAL->compare = newSVsv(*svp) ;
}
else
- info.btree.compare = NULL ;
+ info->btree.compare = NULL ;
svp = hv_fetch(action, "prefix", 6, FALSE);
if (svp && SvOK(*svp))
{
- info.btree.prefix = btree_prefix ;
+ info->btree.prefix = btree_prefix ;
RETVAL->prefix = newSVsv(*svp) ;
}
else
- info.btree.prefix = NULL ;
+ info->btree.prefix = NULL ;
svp = hv_fetch(action, "flags", 5, FALSE);
- info.btree.flags = svp ? SvIV(*svp) : 0;
+ info->btree.flags = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.btree.cachesize = svp ? SvIV(*svp) : 0;
+ info->btree.cachesize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "minkeypage", 10, FALSE);
- info.btree.minkeypage = svp ? SvIV(*svp) : 0;
+ info->btree.minkeypage = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "maxkeypage", 10, FALSE);
- info.btree.maxkeypage = svp ? SvIV(*svp) : 0;
+ info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "psize", 5, FALSE);
- info.btree.psize = svp ? SvIV(*svp) : 0;
+ info->btree.psize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.btree.lorder = svp ? SvIV(*svp) : 0;
+ info->btree.lorder = svp ? SvIV(*svp) : 0;
PrintBtree(info) ;
else if (sv_isa(sv, "DB_File::RECNOINFO"))
{
RETVAL->type = DB_RECNO ;
- openinfo = (void *)&info ;
+ openinfo = (void *)info ;
svp = hv_fetch(action, "flags", 5, FALSE);
- info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
+ info->recno.flags = (u_long) svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
+ info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "psize", 5, FALSE);
- info.recno.psize = (int) svp ? SvIV(*svp) : 0;
+ info->recno.psize = (int) svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
+ info->recno.lorder = (int) svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "reclen", 6, FALSE);
- info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
+ info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "bval", 4, FALSE);
if (svp && SvOK(*svp))
{
if (SvPOK(*svp))
- info.recno.bval = (u_char)*SvPV(*svp, na) ;
+ info->recno.bval = (u_char)*SvPV(*svp, na) ;
else
- info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
+ info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
}
else
{
- if (info.recno.flags & R_FIXEDLEN)
- info.recno.bval = (u_char) ' ' ;
+ if (info->recno.flags & R_FIXEDLEN)
+ info->recno.bval = (u_char) ' ' ;
else
- info.recno.bval = (u_char) '\n' ;
+ info->recno.bval = (u_char) '\n' ;
}
svp = hv_fetch(action, "bfname", 6, FALSE);
if (svp) {
char * ptr = SvPV(*svp,na) ;
- info.recno.bfname = (char*) na ? ptr : 0 ;
+ info->recno.bfname = (char*) na ? ptr : 0 ;
}
PrintRecno(info) ;
DB_File
-db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
+db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
char * dbtype
int flags
int mode
- ALIAS: TIEARRAY = 1
CODE:
{
char * name = (char *) NULL ;
if (items == 5)
sv = ST(4) ;
- RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
+ RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
if (RETVAL->dbp == NULL)
RETVAL = NULL ;
}
OUTPUT:
key
value
+
-#!./perl
#!./perl -w
BEGIN {
- #@INC = '../lib' if -d '../lib' ;
- @INC = '../lib' ;
+ @INC = '../lib' if -d '../lib' ;
require Config; import Config;
if ($Config{'extensions'} !~ /\bDB_File\b/) {
print "1..0\n";
use DB_File;
use Fcntl;
-print "1..48\n";
+print "1..51\n";
sub ok
{
my $dbh = new DB_File::HASHINFO ;
+ok(1, $dbh->{bsize} == 0) ;
+ok(2, $dbh->{ffactor} == 0) ;
+ok(3, $dbh->{nelem} == 0) ;
+ok(4, $dbh->{cachesize} == 0) ;
$^W = 0 ;
-ok(1, $dbh->{bsize} == undef) ;
-ok(2, $dbh->{ffactor} == undef) ;
-ok(3, $dbh->{nelem} == undef) ;
-ok(4, $dbh->{cachesize} == undef) ;
ok(5, $dbh->{hash} == undef) ;
-ok(6, $dbh->{lorder} == undef) ;
$^W = 1 ;
+ok(6, $dbh->{lorder} == 0) ;
$dbh->{bsize} = 3000 ;
ok(7, $dbh->{bsize} == 3000 );
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
-eval '$q = $dbh->{fred}' ;
+eval 'my $q = $dbh->{fred}' ;
ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
# Now check the interface to HASH
ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
$status = $X->fd ;
ok(48, $status == -1 );
-untie %h ;
undef $X ;
+untie %h ;
+
+{
+ # check ability to override the default hashing
+ my %x ;
+ my $filename = "xyz" ;
+ my $hi = new DB_File::HASHINFO ;
+ $::count = 0 ;
+ $hi->{hash} = sub { ++$::count ; length $_[0] } ;
+ ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
+ $h{"abc"} = 123 ;
+ ok(50, $h{"abc"} == 123) ;
+ untie %x ;
+ unlink $filename ;
+ ok(51, $::count >0) ;
+}
exit ;
projects / p5sagit/p5-mst-13.2.git / commitdiff