1.77 26th April 2001
- * AIX is reported to need -lpthreads, so Makefile.PL now checks for AIX and
- adds it to the link options.
+ * AIX is reported to need -lpthreads, so Makefile.PL now checks for
+ AIX and adds it to the link options.
* Minor documentation updates.
1.79 22nd October 2001
- * Added a "local $SIG{__DIE__}" inside the eval that checks for the presence
- of XSLoader s suggested by Andrew Hryckowin.
+ * Added a "local $SIG{__DIE__}" inside the eval that checks for
+ the presence of XSLoader s suggested by Andrew Hryckowin.
* merged core patch 12277.
* Changed NEXTKEY to not initialise the input key. It isn't used anyway.
+
+1.79 22nd October 2001
+
+ * Fixed test harness for cygwin
+
+
+1.800 23rd November 2001
+
+ * use pport.h for perl backward compatability code.
+
+ * use new ExtUtils::Constant module to generate XS constants.
+
+ * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with
+ "use vars"
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 22nc Oct 2001
-# version 1.79
+# last modified 23rd Nov 2001
+# version 1.800
#
# Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
use warnings;
use strict;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO
- $db_version $use_XSLoader
- ) ;
+our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
+our ($db_version, $use_XSLoader);
use Carp;
-$VERSION = "1.79" ;
+$VERSION = "1.800" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- my($pack,$file,$line) = caller;
- croak "Your vendor has not defined DB macro $constname, used at $file line $line.
-";
- }
- }
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
no strict 'refs';
*{$AUTOLOAD} = sub { $val };
goto &{$AUTOLOAD};
-}
+}
eval {
use warnings ;
use strict ;
use DB_File ;
- use vars qw( %h $k $v ) ;
+ our (%h, $k, $v) ;
unlink "fruit" ;
tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH
use strict ;
use DB_File ;
- use vars qw($filename %h ) ;
+ our ($filename, %h) ;
$filename = "tree" ;
unlink $filename ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $status $key $value) ;
+ our ($filename, $x, %h, $status, $key, $value) ;
$filename = "tree" ;
unlink $filename ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h ) ;
+ our ($filename, $x, %h) ;
$filename = "tree" ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $found) ;
+ our ($filename, $x, %h, $found) ;
- my $filename = "tree" ;
+ $filename = "tree" ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $found) ;
+ our ($filename, $x, %h, $found) ;
- my $filename = "tree" ;
+ $filename = "tree" ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
use DB_File ;
use Fcntl ;
- use vars qw($filename $x %h $st $key $value) ;
+ our ($filename, $x, %h, $st, $key, $value) ;
sub match
{
use warnings ;
use strict ;
- use vars qw(@h $H $file $i) ;
+ our (@h, $H, $file, $i) ;
use DB_File ;
use Fcntl ;
use DB_File ;
use Fcntl ;
- use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
+ our ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ;
$dotdir = $ENV{HOME} || $ENV{LOGNAME};
$HISTORY = "$dotdir/.netscape/history.db";
use warnings ;
use strict ;
use DB_File ;
- use vars qw(%x) ;
+ my %x ;
tie %x, DB_File, "filename" ;
Running it produces the error in question:
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 22nd Oct 2001
- version 1.79
+ last modified 23rd Nov 2001
+ version 1.800
All comments/suggestions/problems are welcome
1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included.
1.79 - NEXTKEY ignores the input key.
Added lots of casts
+ 1.800 - Moved backward compatability code into ppport.h.
+ Use the new constants code.
*/
#include "perl.h"
#include "XSUB.h"
-#ifndef PERL_VERSION
-# include "patchlevel.h"
-# define PERL_REVISION 5
-# define PERL_VERSION PATCHLEVEL
-# define PERL_SUBVERSION SUBVERSION
-#endif
-
-#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
-
-# define PL_sv_undef sv_undef
-# define PL_na na
-
-#endif
-
-/* DEFSV appears first in 5.004_56 */
-#ifndef DEFSV
-# define DEFSV GvSV(defgv)
+#ifdef _NOT_CORE
+# include "ppport.h"
#endif
/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
-/* If Perl has been compiled with Threads support,the symbol op will
- be defined here. This clashes with a field name in db.h, so get rid of it.
- */
-#ifdef op
-# undef op
-#endif
-
#ifdef COMPAT185
# include <db_185.h>
#else
#endif /* Perl >= 5.7 */
-#ifndef pTHX
-# define pTHX
-# define pTHX_
-# define aTHX
-# define aTHX_
-#endif
-
-#ifndef newSVpvn
-# define newSVpvn(a,b) newSVpv(a,b)
-#endif
-
#include <fcntl.h>
/* #define TRACE */
#endif
/* Internal Global Data */
+
#define MY_CXT_KEY "DB_File::_guts" XS_VERSION
typedef struct {
} /* ParseOpenInfo */
-static double
-#ifdef CAN_PROTOTYPE
-constant(char *name, int arg)
-#else
-constant(name, arg)
-char *name;
-int arg;
-#endif
-{
- errno = 0;
- switch (*name) {
- case 'A':
- break;
- case 'B':
- if (strEQ(name, "BTREEMAGIC"))
-#ifdef BTREEMAGIC
- return BTREEMAGIC;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "BTREEVERSION"))
-#ifdef BTREEVERSION
- return BTREEVERSION;
-#else
- goto not_there;
-#endif
- break;
- case 'C':
- break;
- case 'D':
- if (strEQ(name, "DB_LOCK"))
-#ifdef DB_LOCK
- return DB_LOCK;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "DB_SHMEM"))
-#ifdef DB_SHMEM
- return DB_SHMEM;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "DB_TXN"))
-#ifdef DB_TXN
- return (U32)DB_TXN;
-#else
- goto not_there;
-#endif
- break;
- case 'E':
- break;
- case 'F':
- break;
- case 'G':
- break;
- case 'H':
- if (strEQ(name, "HASHMAGIC"))
-#ifdef HASHMAGIC
- return HASHMAGIC;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "HASHVERSION"))
-#ifdef HASHVERSION
- return HASHVERSION;
-#else
- goto not_there;
-#endif
- break;
- case 'I':
- break;
- case 'J':
- break;
- case 'K':
- break;
- case 'L':
- break;
- case 'M':
- if (strEQ(name, "MAX_PAGE_NUMBER"))
-#ifdef MAX_PAGE_NUMBER
- return (U32)MAX_PAGE_NUMBER;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "MAX_PAGE_OFFSET"))
-#ifdef MAX_PAGE_OFFSET
- return MAX_PAGE_OFFSET;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "MAX_REC_NUMBER"))
-#ifdef MAX_REC_NUMBER
- return (U32)MAX_REC_NUMBER;
-#else
- goto not_there;
-#endif
- break;
- case 'N':
- break;
- case 'O':
- break;
- case 'P':
- break;
- case 'Q':
- break;
- case 'R':
- if (strEQ(name, "RET_ERROR"))
-#ifdef RET_ERROR
- return RET_ERROR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "RET_SPECIAL"))
-#ifdef RET_SPECIAL
- return RET_SPECIAL;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "RET_SUCCESS"))
-#ifdef RET_SUCCESS
- return RET_SUCCESS;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_CURSOR"))
-#ifdef R_CURSOR
- return R_CURSOR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_DUP"))
-#ifdef R_DUP
- return R_DUP;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_FIRST"))
-#ifdef R_FIRST
- return R_FIRST;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_FIXEDLEN"))
-#ifdef R_FIXEDLEN
- return R_FIXEDLEN;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_IAFTER"))
-#ifdef R_IAFTER
- return R_IAFTER;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_IBEFORE"))
-#ifdef R_IBEFORE
- return R_IBEFORE;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_LAST"))
-#ifdef R_LAST
- return R_LAST;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_NEXT"))
-#ifdef R_NEXT
- return R_NEXT;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_NOKEY"))
-#ifdef R_NOKEY
- return R_NOKEY;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_NOOVERWRITE"))
-#ifdef R_NOOVERWRITE
- return R_NOOVERWRITE;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_PREV"))
-#ifdef R_PREV
- return R_PREV;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_RECNOSYNC"))
-#ifdef R_RECNOSYNC
- return R_RECNOSYNC;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_SETCURSOR"))
-#ifdef R_SETCURSOR
- return R_SETCURSOR;
-#else
- goto not_there;
-#endif
- if (strEQ(name, "R_SNAPSHOT"))
-#ifdef R_SNAPSHOT
- return R_SNAPSHOT;
-#else
- goto not_there;
-#endif
- break;
- case 'S':
- break;
- case 'T':
- break;
- case 'U':
- break;
- case 'V':
- break;
- case 'W':
- break;
- case 'X':
- break;
- case 'Y':
- break;
- case 'Z':
- break;
- case '_':
- break;
- }
- errno = EINVAL;
- return 0;
-
-not_there:
- errno = ENOENT;
- return 0;
-}
+#include "constants.h"
MODULE = DB_File PACKAGE = DB_File PREFIX = db_
+INCLUDE: constants.xs
+
BOOT:
{
MY_CXT_INIT;
empty.size = sizeof(recno_t) ;
}
-double
-constant(name,arg)
- char * name
- int arg
DB_File
DBTKEY key
u_int flags
PREINIT:
- dMY_CXT ;
- int RETVAL ;
+ dMY_CXT ;
+ int RETVAL ;
CODE:
{
DBT value ;
db_FIRSTKEY(db)
DB_File db
PREINIT:
- dMY_CXT ;
- int RETVAL ;
+ dMY_CXT ;
+ int RETVAL ;
CODE:
{
DBTKEY key ;
DB_File db
DBTKEY key = NO_INIT
PREINIT:
- dMY_CXT ;
- int RETVAL ;
+ dMY_CXT ;
+ int RETVAL ;
CODE:
{
DBT value ;
dMY_CXT;
ALIAS: POP = 1
PREINIT:
- I32 RETVAL;
+ I32 RETVAL;
CODE:
{
DBTKEY key ;
dMY_CXT;
ALIAS: SHIFT = 1
PREINIT:
- I32 RETVAL;
+ I32 RETVAL;
CODE:
{
DBT value ;
db_fd(db)
DB_File db
PREINIT:
- dMY_CXT ;
+ dMY_CXT ;
CODE:
CurrentDB = db ;
#ifdef DB_VERSION_MAJOR
+use strict;
+use warnings;
+
use ExtUtils::MakeMaker 5.16 ;
+use ExtUtils::Constant qw(WriteConstants);
use Config ;
# OS2 is a special case, so check for it now.
OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)',
XSPROTOARG => '-noprototypes',
DEFINE => $OS2 || "",
- INC => ($^O eq "MacOS" ? "-i ::::db:include" : "")
+ INC => ($^O eq "MacOS" ? "-i ::::db:include" : ""),
+ 'depend' => {"version$(OBJ_EXT)" => 'version.c'},
+ );
+
+my @names = qw(
+ BTREEMAGIC
+ BTREEVERSION
+ DB_LOCK
+ DB_SHMEM
+ DB_TXN
+ HASHMAGIC
+ HASHVERSION
+ MAX_PAGE_NUMBER
+ MAX_PAGE_OFFSET
+ MAX_REC_NUMBER
+ RET_ERROR
+ RET_SPECIAL
+ RET_SUCCESS
+ R_CURSOR
+ R_DUP
+ R_FIRST
+ R_FIXEDLEN
+ R_IAFTER
+ R_IBEFORE
+ R_LAST
+ R_NEXT
+ R_NOKEY
+ R_NOOVERWRITE
+ R_PREV
+ R_RECNOSYNC
+ R_SETCURSOR
+ R_SNAPSHOT
+ __R_UNUSED
);
-sub MY::postamble {
- '
-version$(OBJ_EXT): version.c
+ # Check the constants above all appear in @EXPORT in DB_File.pm
+ my %names = map { $_, 1} @names;
+ open F, "<DB_File.pm" or die "Cannot open DB_File.pm: $!\n";
+ while (<F>)
+ {
+ last if /^\s*\@EXPORT\s+=\s+qw\(/ ;
+ }
+
+ while (<F>)
+ {
+ last if /^\s*\)/ ;
+ /(\S+)/ ;
+ delete $names{$1} if defined $1 ;
+ }
+ close F ;
-' ;
-}
+ if ( keys %names )
+ {
+ my $missing = join ("\n\t", sort keys %names) ;
+ die "The following names are missing from \@EXPORT in DB_File.pm\n" .
+ "\t$missing\n" ;
+ }
+
+ WriteConstants( NAME => 'DB_File',
+ NAMES => \@names,
+ C_FILE => 'constants.h',
+ XS_FILE => 'constants.xs',
+ );
use warnings ;
use strict ;
- use vars qw( @ISA @EXPORT) ;
+ our (@ISA, @EXPORT);
require Exporter ;
use DB_File;
use strict ;
use DB_File ;
- use vars qw($filename %h ) ;
+ our ($filename, %h);
$filename = "tree" ;
unlink $filename ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $status $key $value) ;
+ our ($filename, $x, %h, $status, $key, $value);
$filename = "tree" ;
unlink $filename ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h ) ;
+ our ($filename, $x, %h);
$filename = "tree" ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $found) ;
+ our ($filename, $x, %h, $found);
- my $filename = "tree" ;
+ $filename = "tree" ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h $found) ;
+ our ($filename, $x, %h, $found);
- my $filename = "tree" ;
+ $filename = "tree" ;
# Enable duplicate records
$DB_BTREE->{'flags'} = R_DUP ;
use DB_File ;
use Fcntl ;
- use vars qw($filename $x %h $st $key $value) ;
+ our ($filename, $x, %h, $st, $key, $value);
sub match
{
}
}
-use strict;
-use warnings;
use DB_File;
use Fcntl;
use warnings ;
use strict ;
- use vars qw( @ISA @EXPORT) ;
+ our (@ISA, @EXPORT);
require Exporter ;
use DB_File;
use warnings FATAL => qw(all);
use strict ;
use DB_File ;
- use vars qw( %h $k $v ) ;
+ our (%h, $k, $v);
unlink "fruit" ;
tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
use DB_File;
use Fcntl;
-use vars qw($dbh $Dfile $bad_ones $FA) ;
+our ($dbh, $Dfile, $bad_ones, $FA);
# full tied array support started in Perl 5.004_57
# Double check to see if it is available.
$total_tests += $splice_tests if $FA ;
print "1..$total_tests\n";
-my $Dfile = "recno.tmp";
+$Dfile = "recno.tmp";
unlink $Dfile ;
umask(0);
# Check the interface to RECNOINFO
-my $dbh = new DB_File::RECNOINFO ;
+$dbh = new DB_File::RECNOINFO ;
ok(1, ! defined $dbh->{bval}) ;
ok(2, ! defined $dbh->{cachesize}) ;
ok(3, ! defined $dbh->{psize}) ;
use warnings ;
use strict ;
- use vars qw( @ISA @EXPORT) ;
+ our (@ISA, @EXPORT);
require Exporter ;
use DB_File;
use warnings FATAL => qw(all);
use strict ;
- use vars qw(@h $H $file $i) ;
+ our (@h, $H, $file, $i);
use DB_File ;
use Fcntl ;
projects / p5sagit/p5-mst-13.2.git / commitdiff