ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
+ext/DB_File/dbinfo Berkeley DB database version checker
ext/DB_File/typemap Berkeley DB extension interface types
ext/DynaLoader/DynaLoader.pm.PL Dynamic Loader perl module
ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
specified as 0, it does a strlen on the data. This was ok for DB
1.x, but isn't for DB 2.x.
+1.59
+ Updated the license section.
+
+ Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in
+ db-btree.t and test 27 in db-hash.t failed because of this change.
+ Those tests have been zapped.
+
+ Added dbinfo to the distribution.
+
+1.60
+ Changed the test to check for full tied array support
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 20th Dec 1997
-# version 1.57
+# last modified 16th May 1998
+# version 1.60
#
-# Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-8 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use Carp;
-$VERSION = "1.58" ;
+$VERSION = "1.60" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
for ($key = $current_length - 1 ; $key >= $length ; -- $key)
{ $self->del($key) }
}
- elsif ($length > $current_length)
- { $self->put($length-1, "") }
+ elsif ($length > $current_length) {
+ $self->put($length-1, "") ;
+ }
}
sub get_dup
=head1 COPYRIGHT
-Copyright (c) 1997 Paul Marquess. All rights reserved. This program is
-free software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
+Copyright (c) 1995-8 Paul Marquess. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
Although B<DB_File> is covered by the Perl license, the library it
makes use of, namely Berkeley DB, is not. Berkeley DB has its own
copyright and its own license. Please take the time to read it.
-The license for Berkeley DB version 2, and how it relates to DB_File
-does need some extra clarification. Here are are few words taken from
-the Berkeley DB FAQ regarding the version 2 license:
-
- The major difference is that the license for DB 2.0, when
- downloaded from the net, requires that the software that
- uses DB 2.0 be freely redistributable.
-
-That means that if you want to use DB_File, and you have changed either
-the source for Berkeley DB or Perl, then the changes must be freely
-available.
+Here are are few words taken from the Berkeley DB FAQ (at
+http://www.sleepycat.com) regarding the license:
-In the case of Perl, the term source refers to the complete source
-code for Perl (e.g. sv.c, toke.c, perl.h) and any external modules that
-you are using (e.g. DB_File, Tk).
+ Do I have to license DB to use it in Perl scripts?
-Note that any Perl scripts that you write are your property - this
-includes scripts that make use of DB_File. Neither the Perl license or
-the Berkeley DB license place any restriction on what you have to do
-with them.
+ No. The Berkeley DB license requires that software that uses
+ Berkeley DB be freely redistributable. In the case of Perl, that
+ software is Perl, and not your scripts. Any Perl scripts that you
+ write are your property, including scripts that make use of
+ Berkeley DB. Neither the Perl license nor the Berkeley DB license
+ place any restriction on what you may do with them.
If you are in any doubt about the license situation, contact either the
Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 2nd Feb 1998
- version 1.58
+ last modified 16th May 1998
+ version 1.60
All comments/suggestions/problems are welcome
1.58 - Fixed a problem with the use of sv_setpvn. When the
size is specified as 0, it does a strlen on the data.
This was ok for DB 1.x, but isn't for DB 2.x.
+ 1.59 - No change to DB_File.xs
+ 1.60 - Some code tidy up
/* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
RETVAL = db_get(db, key, value, flags) ;
ST(0) = sv_newmortal();
- if (RETVAL == 0)
- my_sv_setpvn(ST(0), value.data, value.size);
+ OutputValue(ST(0), value)
}
int
CurrentDB = db ;
RETVAL = do_SEQ(db, key, value, R_FIRST) ;
ST(0) = sv_newmortal();
- if (RETVAL == 0)
- {
- if (db->type != DB_RECNO)
- my_sv_setpvn(ST(0), key.data, key.size);
- else
- sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
- }
+ OutputKey(ST(0), key) ;
}
int
CurrentDB = db ;
RETVAL = do_SEQ(db, key, value, R_NEXT) ;
ST(0) = sv_newmortal();
- if (RETVAL == 0)
- {
- if (db->type != DB_RECNO)
- my_sv_setpvn(ST(0), key.data, key.size);
- else
- sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
- }
+ OutputKey(ST(0), key) ;
}
#
if (RETVAL == 0)
{
/* the call to del will trash value, so take a copy now */
- my_sv_setpvn(ST(0), value.data, value.size);
+ OutputValue(ST(0), value) ;
RETVAL = db_del(db, key, R_CURSOR) ;
if (RETVAL != 0)
sv_setsv(ST(0), &sv_undef);
if (RETVAL == 0)
{
/* the call to del will trash value, so take a copy now */
- my_sv_setpvn(ST(0), value.data, value.size);
+ OutputValue(ST(0), value) ;
RETVAL = db_del(db, key, R_CURSOR) ;
if (RETVAL != 0)
sv_setsv (ST(0), &sv_undef) ;
--- /dev/null
+#!/usr/local/bin/perl
+
+# Name: dbinfo -- identify berkeley DB version used to create
+# a database file
+#
+# Author: Paul Marquess
+# Version: 1.01
+# Date 16th April 1998
+#
+# Copyright (c) 1998 Paul Marquess. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# Todo: Print more stats on a db file, e.g. no of records
+# add log/txn/lock files
+
+use strict ;
+
+my %Data =
+ (
+ 0x053162 => {
+ Type => "Btree",
+ Versions =>
+ {
+ 1 => "Unknown (older than 1.71)",
+ 2 => "Unknown (older than 1.71)",
+ 3 => "1.71 -> 1.85, 1.86",
+ 4 => "Unknown",
+ 5 => "2.0.0 -> 2.3.0",
+ 6 => "2.3.1 or greater",
+ }
+ },
+ 0x061561 => {
+ Type => "Hash",
+ Versions =>
+ {
+ 1 => "Unknown (older than 1.71)",
+ 2 => "1.71 -> 1.85",
+ 3 => "1.86",
+ 4 => "2.0.0 -> 2.1.0",
+ 5 => "2.2.6 or greater",
+ }
+ },
+ ) ;
+
+die "Usage: dbinfo file\n" unless @ARGV == 1 ;
+
+print "testing file $ARGV[0]...\n\n" ;
+open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ;
+
+my $buff ;
+read F, $buff, 20 ;
+
+my (@info) = unpack("NNNNN", $buff) ;
+my (@info1) = unpack("VVVVV", $buff) ;
+my ($magic, $version, $endian) ;
+
+if ($Data{$info[0]}) # first try DB 1.x format
+{
+ $magic = $info[0] ;
+ $version = $info[1] ;
+ $endian = "Unknown" ;
+}
+elsif ($Data{$info[3]}) # next DB 2.x big endian
+{
+ $magic = $info[3] ;
+ $version = $info[4] ;
+ $endian = "Big Endian" ;
+}
+elsif ($Data{$info1[3]}) # next DB 2.x little endian
+{
+ $magic = $info1[3] ;
+ $version = $info1[4] ;
+ $endian = "Little Endian" ;
+}
+else
+ { die "not a Berkeley DB database file.\n" }
+
+my $type = $Data{$magic} ;
+my $magic = sprintf "%06X", $magic ;
+
+my $ver_string = "Unknown" ;
+$ver_string = $type->{Versions}{$version}
+ if defined $type->{Versions}{$version} ;
+
+print <<EOM ;
+File Type: Berkeley DB $type->{Type} file.
+File Version ID: $version
+Built with Berkeley DB: $ver_string
+Byte Order: $endian
+Magic: $magic
+EOM
+
+close F ;
+
+exit ;
# typemap for Perl 5 interface to Berkeley
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 9th Sept 1997
-# version 1.53
+# last modified 13th May 1998
+# version 1.59
#
#################################### DB SECTION
#
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
+ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
while (($key,$value) = each(%h)) {
$i++;
$h{'foo'} = '';
ok(31, $h{'foo'} eq '' ) ;
-$h{''} = 'bar';
-ok(32, $h{''} eq 'bar' );
+#$h{''} = 'bar';
+#ok(32, $h{''} eq 'bar' );
+ok(32,1) ;
# check cache overflow and numeric keys and contents
$ok = 1;
$status = $X->del('q') ;
ok(41, $status == 0 );
-$status = $X->del('') ;
-ok(42, $status == 0 );
+#$status = $X->del('') ;
+#ok(42, $status == 0 );
+ok(42,1) ;
# Make sure that the key deleted, cannot be retrieved
ok(43, ! defined $h{'q'}) ;
ok(64, $value eq 'replace value' );
$status = $X->get('y', $value) ;
ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
- # only worked because of a bug in 1.85/6
-
+ # only worked because of a bug in 1.85/6
# use seq to walk forwards through a file
unlink $filename ;
}
-
{
# sub-class test
close FILE ;
- BEGIN { push @INC, '.'; }
+ BEGIN { push @INC, '.'; }
eval 'use SubDB ; ';
main::ok(93, $@ eq "") ;
my %h ;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
+ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
while (($key,$value) = each(%h)) {
$i++;
$h{'foo'} = '';
ok(26, $h{'foo'} eq '' );
-$h{''} = 'bar';
-ok(27, $h{''} eq 'bar' );
+#$h{''} = 'bar';
+#ok(27, $h{''} eq 'bar' );
+ok(27,1) ;
# check cache overflow and numeric keys and contents
$ok = 1;
close FILE ;
- BEGIN { push @INC, '.'; }
+ BEGIN { push @INC, '.'; }
eval 'use SubDB ; ';
main::ok(53, $@ eq "") ;
my %h ;
unlink "SubDB.pm", "dbhash.tmp" ;
}
-
exit ;
use vars qw($dbh $Dfile $bad_ones $FA) ;
# full tied array support started in Perl 5.004_57
-$FA = ($] >= 5.004_57) ;
+# Double check to see if it is available.
+
+{
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ $FA = 0 ;
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+}
+
sub ok
{
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' || $^O eq 'MSWin32') ? 0666 : 0640)
- || $^O eq 'amigaos') ;
+ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
+ || $^O eq 'MSWin32' || $^O eq 'amigaos') ;
#my $l = @h ;
my $l = $X->length ;
projects / p5sagit/p5-mst-13.2.git / commitdiff