summaryrefslogtreecommitdiff
path: root/lang/perl
diff options
context:
space:
mode:
authorLorry <lorry@roadtrain.codethink.co.uk>2012-07-20 20:00:05 +0100
committerLorry <lorry@roadtrain.codethink.co.uk>2012-07-20 20:00:05 +0100
commit3ef782d3745ea8f25a3151561a3cfb882190210e (patch)
tree86b9c2f5fde051dd0bced99b3fc9f5a3ba08db69 /lang/perl
downloadberkeleydb-3ef782d3745ea8f25a3151561a3cfb882190210e.tar.gz
Tarball conversion
Diffstat (limited to 'lang/perl')
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB.pm2045
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB.pod2590
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB.pod.P2357
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB.xs5662
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB/Btree.pm8
-rw-r--r--lang/perl/BerkeleyDB/BerkeleyDB/Hash.pm8
-rw-r--r--lang/perl/BerkeleyDB/Changes428
-rw-r--r--lang/perl/BerkeleyDB/MANIFEST71
-rw-r--r--lang/perl/BerkeleyDB/META.yml21
-rw-r--r--lang/perl/BerkeleyDB/Makefile.PL152
-rw-r--r--lang/perl/BerkeleyDB/README672
-rw-r--r--lang/perl/BerkeleyDB/Todo57
-rw-r--r--lang/perl/BerkeleyDB/config.in45
-rw-r--r--lang/perl/BerkeleyDB/constants.h7112
-rw-r--r--lang/perl/BerkeleyDB/constants.xs89
-rwxr-xr-xlang/perl/BerkeleyDB/dbinfo141
-rw-r--r--lang/perl/BerkeleyDB/hints/dec_osf.pl1
-rw-r--r--lang/perl/BerkeleyDB/hints/irix_6_5.pl1
-rw-r--r--lang/perl/BerkeleyDB/hints/solaris.pl1
-rw-r--r--lang/perl/BerkeleyDB/mkconsts.pl1149
-rwxr-xr-xlang/perl/BerkeleyDB/mkpod146
-rw-r--r--lang/perl/BerkeleyDB/patches/5.00493
-rw-r--r--lang/perl/BerkeleyDB/patches/5.004_01217
-rw-r--r--lang/perl/BerkeleyDB/patches/5.004_02217
-rw-r--r--lang/perl/BerkeleyDB/patches/5.004_03223
-rw-r--r--lang/perl/BerkeleyDB/patches/5.004_04209
-rw-r--r--lang/perl/BerkeleyDB/patches/5.004_05209
-rw-r--r--lang/perl/BerkeleyDB/patches/5.005209
-rw-r--r--lang/perl/BerkeleyDB/patches/5.005_01209
-rw-r--r--lang/perl/BerkeleyDB/patches/5.005_02264
-rw-r--r--lang/perl/BerkeleyDB/patches/5.005_03250
-rw-r--r--lang/perl/BerkeleyDB/patches/5.6.0294
-rw-r--r--lang/perl/BerkeleyDB/ppport.h349
-rw-r--r--lang/perl/BerkeleyDB/scan.pl241
-rw-r--r--lang/perl/BerkeleyDB/t/Test/Builder.pm1625
-rw-r--r--lang/perl/BerkeleyDB/t/Test/More.pm1493
-rw-r--r--lang/perl/BerkeleyDB/t/btree.t936
-rw-r--r--lang/perl/BerkeleyDB/t/cds.t73
-rw-r--r--lang/perl/BerkeleyDB/t/db-3.0.t85
-rw-r--r--lang/perl/BerkeleyDB/t/db-3.1.t242
-rw-r--r--lang/perl/BerkeleyDB/t/db-3.2.t57
-rw-r--r--lang/perl/BerkeleyDB/t/db-3.3.t476
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.3.t92
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.4.t57
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.6.t248
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.7.t42
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.8.t324
-rw-r--r--lang/perl/BerkeleyDB/t/db-4.x.t56
-rw-r--r--lang/perl/BerkeleyDB/t/destroy.t100
-rw-r--r--lang/perl/BerkeleyDB/t/encode.t72
-rw-r--r--lang/perl/BerkeleyDB/t/encrypt.t636
-rw-r--r--lang/perl/BerkeleyDB/t/env.t273
-rw-r--r--lang/perl/BerkeleyDB/t/examples.t403
-rw-r--r--lang/perl/BerkeleyDB/t/examples.t.T417
-rw-r--r--lang/perl/BerkeleyDB/t/examples3.t139
-rw-r--r--lang/perl/BerkeleyDB/t/examples3.t.T143
-rw-r--r--lang/perl/BerkeleyDB/t/filter.t326
-rw-r--r--lang/perl/BerkeleyDB/t/hash.t732
-rw-r--r--lang/perl/BerkeleyDB/t/join.t235
-rw-r--r--lang/perl/BerkeleyDB/t/mldbm.t110
-rw-r--r--lang/perl/BerkeleyDB/t/pod.t18
-rw-r--r--lang/perl/BerkeleyDB/t/queue.t875
-rw-r--r--lang/perl/BerkeleyDB/t/recno.t915
-rw-r--r--lang/perl/BerkeleyDB/t/sequence.t55
-rw-r--r--lang/perl/BerkeleyDB/t/strict.t173
-rw-r--r--lang/perl/BerkeleyDB/t/subdb.t210
-rw-r--r--lang/perl/BerkeleyDB/t/txn.t316
-rw-r--r--lang/perl/BerkeleyDB/t/unknown.t211
-rw-r--r--lang/perl/BerkeleyDB/t/util.pm354
-rw-r--r--lang/perl/BerkeleyDB/typemap403
-rw-r--r--lang/perl/DB_File/Changes572
-rw-r--r--lang/perl/DB_File/DB_File.pm2316
-rw-r--r--lang/perl/DB_File/DB_File.xs1995
-rw-r--r--lang/perl/DB_File/DB_File_BS6
-rw-r--r--lang/perl/DB_File/MANIFEST32
-rw-r--r--lang/perl/DB_File/META.yml21
-rw-r--r--lang/perl/DB_File/Makefile.PL358
-rw-r--r--lang/perl/DB_File/README585
-rw-r--r--lang/perl/DB_File/config.in97
-rw-r--r--lang/perl/DB_File/dbinfo133
-rw-r--r--lang/perl/DB_File/fallback.h455
-rw-r--r--lang/perl/DB_File/fallback.xs88
-rw-r--r--lang/perl/DB_File/hints/dynixptx.pl3
-rw-r--r--lang/perl/DB_File/hints/sco.pl2
-rw-r--r--lang/perl/DB_File/patches/5.00493
-rw-r--r--lang/perl/DB_File/patches/5.004_01217
-rw-r--r--lang/perl/DB_File/patches/5.004_02217
-rw-r--r--lang/perl/DB_File/patches/5.004_03223
-rw-r--r--lang/perl/DB_File/patches/5.004_04209
-rw-r--r--lang/perl/DB_File/patches/5.004_05209
-rw-r--r--lang/perl/DB_File/patches/5.005209
-rw-r--r--lang/perl/DB_File/patches/5.005_01209
-rw-r--r--lang/perl/DB_File/patches/5.005_02264
-rw-r--r--lang/perl/DB_File/patches/5.005_03250
-rw-r--r--lang/perl/DB_File/patches/5.6.0294
-rw-r--r--lang/perl/DB_File/ppport.h364
-rw-r--r--lang/perl/DB_File/t/db-btree.t1657
-rw-r--r--lang/perl/DB_File/t/db-hash.t1225
-rw-r--r--lang/perl/DB_File/t/db-recno.t1595
-rw-r--r--lang/perl/DB_File/t/pod.t18
-rw-r--r--lang/perl/DB_File/typemap57
-rw-r--r--lang/perl/DB_File/version.c83
102 files changed, 52718 insertions, 0 deletions
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB.pm b/lang/perl/BerkeleyDB/BerkeleyDB.pm
new file mode 100644
index 00000000..45f64c87
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB.pm
@@ -0,0 +1,2045 @@
+
+package BerkeleyDB;
+
+
+# Copyright (c) 1997-2011 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.
+#
+
+# The documentation for this module is at the bottom of this file,
+# after the line __END__.
+
+BEGIN { require 5.005 }
+
+use strict;
+use Carp;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD
+ $use_XSLoader);
+
+$VERSION = '0.50';
+
+require Exporter;
+#require DynaLoader;
+require AutoLoader;
+
+BEGIN {
+ $use_XSLoader = 1 ;
+ { local $SIG{__DIE__} ; eval { require XSLoader } ; }
+
+ if ($@) {
+ $use_XSLoader = 0 ;
+ require DynaLoader;
+ @ISA = qw(DynaLoader);
+ }
+}
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# NOTE -- Do not add to @EXPORT directly. It is written by mkconsts
+@EXPORT = qw(
+ DB2_AM_EXCL
+ DB2_AM_INTEXCL
+ DB2_AM_NOWAIT
+ DB_AFTER
+ DB_AGGRESSIVE
+ DB_ALREADY_ABORTED
+ DB_APPEND
+ DB_APPLY_LOGREG
+ DB_APP_INIT
+ DB_ARCH_ABS
+ DB_ARCH_DATA
+ DB_ARCH_LOG
+ DB_ARCH_REMOVE
+ DB_ASSOC_CREATE
+ DB_ASSOC_IMMUTABLE_KEY
+ DB_AUTO_COMMIT
+ DB_BACKUP_CLEAN
+ DB_BACKUP_FILES
+ DB_BACKUP_NO_LOGS
+ DB_BACKUP_READ_COUNT
+ DB_BACKUP_READ_SLEEP
+ DB_BACKUP_SINGLE_DIR
+ DB_BACKUP_SIZE
+ DB_BACKUP_UPDATE
+ DB_BACKUP_WRITE_DIRECT
+ DB_BEFORE
+ DB_BOOTSTRAP_HELPER
+ DB_BTREE
+ DB_BTREEMAGIC
+ DB_BTREEOLDVER
+ DB_BTREEVERSION
+ DB_BUFFER_SMALL
+ DB_CACHED_COUNTS
+ DB_CDB_ALLDB
+ DB_CHECKPOINT
+ DB_CHKSUM
+ DB_CHKSUM_SHA1
+ DB_CKP_INTERNAL
+ DB_CLIENT
+ DB_CL_WRITER
+ DB_COMMIT
+ DB_COMPACT_FLAGS
+ DB_CONSUME
+ DB_CONSUME_WAIT
+ DB_CREATE
+ DB_CURLSN
+ DB_CURRENT
+ DB_CURSOR_BULK
+ DB_CURSOR_TRANSIENT
+ DB_CXX_NO_EXCEPTIONS
+ DB_DATABASE_LOCK
+ DB_DATABASE_LOCKING
+ DB_DEGREE_2
+ DB_DELETED
+ DB_DELIMITER
+ DB_DIRECT
+ DB_DIRECT_DB
+ DB_DIRECT_LOG
+ DB_DIRTY_READ
+ DB_DONOTINDEX
+ DB_DSYNC_DB
+ DB_DSYNC_LOG
+ DB_DUP
+ DB_DUPCURSOR
+ DB_DUPSORT
+ DB_DURABLE_UNKNOWN
+ DB_EID_BROADCAST
+ DB_EID_INVALID
+ DB_EID_MASTER
+ DB_ENCRYPT
+ DB_ENCRYPT_AES
+ DB_ENV_APPINIT
+ DB_ENV_AUTO_COMMIT
+ DB_ENV_CDB
+ DB_ENV_CDB_ALLDB
+ DB_ENV_CREATE
+ DB_ENV_DATABASE_LOCKING
+ DB_ENV_DBLOCAL
+ DB_ENV_DIRECT_DB
+ DB_ENV_DIRECT_LOG
+ DB_ENV_DSYNC_DB
+ DB_ENV_DSYNC_LOG
+ DB_ENV_FAILCHK
+ DB_ENV_FATAL
+ DB_ENV_HOTBACKUP
+ DB_ENV_LOCKDOWN
+ DB_ENV_LOCKING
+ DB_ENV_LOGGING
+ DB_ENV_LOG_AUTOREMOVE
+ DB_ENV_LOG_INMEMORY
+ DB_ENV_MULTIVERSION
+ DB_ENV_NOFLUSH
+ DB_ENV_NOLOCKING
+ DB_ENV_NOMMAP
+ DB_ENV_NOPANIC
+ DB_ENV_NO_OUTPUT_SET
+ DB_ENV_OPEN_CALLED
+ DB_ENV_OVERWRITE
+ DB_ENV_PRIVATE
+ DB_ENV_RECOVER_FATAL
+ DB_ENV_REF_COUNTED
+ DB_ENV_REGION_INIT
+ DB_ENV_REP_CLIENT
+ DB_ENV_REP_LOGSONLY
+ DB_ENV_REP_MASTER
+ DB_ENV_RPCCLIENT
+ DB_ENV_RPCCLIENT_GIVEN
+ DB_ENV_STANDALONE
+ DB_ENV_SYSTEM_MEM
+ DB_ENV_THREAD
+ DB_ENV_TIME_NOTGRANTED
+ DB_ENV_TXN
+ DB_ENV_TXN_NOSYNC
+ DB_ENV_TXN_NOT_DURABLE
+ DB_ENV_TXN_NOWAIT
+ DB_ENV_TXN_SNAPSHOT
+ DB_ENV_TXN_WRITE_NOSYNC
+ DB_ENV_USER_ALLOC
+ DB_ENV_YIELDCPU
+ DB_EVENT_NOT_HANDLED
+ DB_EVENT_NO_SUCH_EVENT
+ DB_EVENT_PANIC
+ DB_EVENT_REG_ALIVE
+ DB_EVENT_REG_PANIC
+ DB_EVENT_REP_CLIENT
+ DB_EVENT_REP_CONNECT_BROKEN
+ DB_EVENT_REP_CONNECT_ESTD
+ DB_EVENT_REP_CONNECT_TRY_FAILED
+ DB_EVENT_REP_DUPMASTER
+ DB_EVENT_REP_ELECTED
+ DB_EVENT_REP_ELECTION_FAILED
+ DB_EVENT_REP_INIT_DONE
+ DB_EVENT_REP_JOIN_FAILURE
+ DB_EVENT_REP_LOCAL_SITE_REMOVED
+ DB_EVENT_REP_MASTER
+ DB_EVENT_REP_MASTER_FAILURE
+ DB_EVENT_REP_NEWMASTER
+ DB_EVENT_REP_PERM_FAILED
+ DB_EVENT_REP_SITE_ADDED
+ DB_EVENT_REP_SITE_REMOVED
+ DB_EVENT_REP_STARTUPDONE
+ DB_EVENT_REP_WOULD_ROLLBACK
+ DB_EVENT_WRITE_FAILED
+ DB_EXCL
+ DB_EXTENT
+ DB_FAILCHK
+ DB_FAILCHK_ISALIVE
+ DB_FAST_STAT
+ DB_FCNTL_LOCKING
+ DB_FILEOPEN
+ DB_FILE_ID_LEN
+ DB_FIRST
+ DB_FIXEDLEN
+ DB_FLUSH
+ DB_FORCE
+ DB_FORCESYNC
+ DB_FOREIGN_ABORT
+ DB_FOREIGN_CASCADE
+ DB_FOREIGN_CONFLICT
+ DB_FOREIGN_NULLIFY
+ DB_FREELIST_ONLY
+ DB_FREE_SPACE
+ DB_GETREC
+ DB_GET_BOTH
+ DB_GET_BOTHC
+ DB_GET_BOTH_LTE
+ DB_GET_BOTH_RANGE
+ DB_GET_RECNO
+ DB_GID_SIZE
+ DB_GROUP_CREATOR
+ DB_HANDLE_LOCK
+ DB_HASH
+ DB_HASHMAGIC
+ DB_HASHOLDVER
+ DB_HASHVERSION
+ DB_HEAP
+ DB_HEAPMAGIC
+ DB_HEAPOLDVER
+ DB_HEAPVERSION
+ DB_HEAP_FULL
+ DB_HEAP_RID_SZ
+ DB_HOTBACKUP_IN_PROGRESS
+ DB_IGNORE_LEASE
+ DB_IMMUTABLE_KEY
+ DB_INCOMPLETE
+ DB_INIT_CDB
+ DB_INIT_LOCK
+ DB_INIT_LOG
+ DB_INIT_MPOOL
+ DB_INIT_MUTEX
+ DB_INIT_REP
+ DB_INIT_TXN
+ DB_INORDER
+ DB_INTERNAL_DB
+ DB_INTERNAL_PERSISTENT_DB
+ DB_INTERNAL_TEMPORARY_DB
+ DB_JAVA_CALLBACK
+ DB_JOINENV
+ DB_JOIN_ITEM
+ DB_JOIN_NOSORT
+ DB_KEYEMPTY
+ DB_KEYEXIST
+ DB_KEYFIRST
+ DB_KEYLAST
+ DB_LAST
+ DB_LEGACY
+ DB_LOCAL_SITE
+ DB_LOCKDOWN
+ DB_LOCKMAGIC
+ DB_LOCKVERSION
+ DB_LOCK_ABORT
+ DB_LOCK_CHECK
+ DB_LOCK_CONFLICT
+ DB_LOCK_DEADLOCK
+ DB_LOCK_DEFAULT
+ DB_LOCK_DUMP
+ DB_LOCK_EXPIRE
+ DB_LOCK_FREE_LOCKER
+ DB_LOCK_GET
+ DB_LOCK_GET_TIMEOUT
+ DB_LOCK_IGNORE_REC
+ DB_LOCK_INHERIT
+ DB_LOCK_MAXLOCKS
+ DB_LOCK_MAXWRITE
+ DB_LOCK_MINLOCKS
+ DB_LOCK_MINWRITE
+ DB_LOCK_NORUN
+ DB_LOCK_NOTEXIST
+ DB_LOCK_NOTGRANTED
+ DB_LOCK_NOTHELD
+ DB_LOCK_NOWAIT
+ DB_LOCK_OLDEST
+ DB_LOCK_PUT
+ DB_LOCK_PUT_ALL
+ DB_LOCK_PUT_OBJ
+ DB_LOCK_PUT_READ
+ DB_LOCK_RANDOM
+ DB_LOCK_RECORD
+ DB_LOCK_REMOVE
+ DB_LOCK_RIW_N
+ DB_LOCK_RW_N
+ DB_LOCK_SET_TIMEOUT
+ DB_LOCK_SWITCH
+ DB_LOCK_TIMEOUT
+ DB_LOCK_TRADE
+ DB_LOCK_UPGRADE
+ DB_LOCK_UPGRADE_WRITE
+ DB_LOCK_YOUNGEST
+ DB_LOGCHKSUM
+ DB_LOGC_BUF_SIZE
+ DB_LOGFILEID_INVALID
+ DB_LOGMAGIC
+ DB_LOGOLDVER
+ DB_LOGVERSION
+ DB_LOGVERSION_LATCHING
+ DB_LOG_AUTOREMOVE
+ DB_LOG_AUTO_REMOVE
+ DB_LOG_BUFFER_FULL
+ DB_LOG_CHKPNT
+ DB_LOG_COMMIT
+ DB_LOG_DIRECT
+ DB_LOG_DISK
+ DB_LOG_DSYNC
+ DB_LOG_INMEMORY
+ DB_LOG_IN_MEMORY
+ DB_LOG_LOCKED
+ DB_LOG_NOCOPY
+ DB_LOG_NOT_DURABLE
+ DB_LOG_NO_DATA
+ DB_LOG_PERM
+ DB_LOG_RESEND
+ DB_LOG_SILENT_ERR
+ DB_LOG_VERIFY_BAD
+ DB_LOG_VERIFY_CAF
+ DB_LOG_VERIFY_DBFILE
+ DB_LOG_VERIFY_ERR
+ DB_LOG_VERIFY_FORWARD
+ DB_LOG_VERIFY_INTERR
+ DB_LOG_VERIFY_PARTIAL
+ DB_LOG_VERIFY_VERBOSE
+ DB_LOG_VERIFY_WARNING
+ DB_LOG_WRNOSYNC
+ DB_LOG_ZERO
+ DB_MAX_PAGES
+ DB_MAX_RECORDS
+ DB_MEM_LOCK
+ DB_MEM_LOCKER
+ DB_MEM_LOCKOBJECT
+ DB_MEM_LOGID
+ DB_MEM_THREAD
+ DB_MEM_TRANSACTION
+ DB_MPOOL_CLEAN
+ DB_MPOOL_CREATE
+ DB_MPOOL_DIRTY
+ DB_MPOOL_DISCARD
+ DB_MPOOL_EDIT
+ DB_MPOOL_EXTENT
+ DB_MPOOL_FREE
+ DB_MPOOL_LAST
+ DB_MPOOL_NEW
+ DB_MPOOL_NEW_GROUP
+ DB_MPOOL_NOFILE
+ DB_MPOOL_NOLOCK
+ DB_MPOOL_PRIVATE
+ DB_MPOOL_TRY
+ DB_MPOOL_UNLINK
+ DB_MULTIPLE
+ DB_MULTIPLE_KEY
+ DB_MULTIVERSION
+ DB_MUTEXDEBUG
+ DB_MUTEXLOCKS
+ DB_MUTEX_ALLOCATED
+ DB_MUTEX_LOCKED
+ DB_MUTEX_LOGICAL_LOCK
+ DB_MUTEX_PROCESS_ONLY
+ DB_MUTEX_SELF_BLOCK
+ DB_MUTEX_SHARED
+ DB_MUTEX_THREAD
+ DB_NEEDSPLIT
+ DB_NEXT
+ DB_NEXT_DUP
+ DB_NEXT_NODUP
+ DB_NOCOPY
+ DB_NODUPDATA
+ DB_NOERROR
+ DB_NOFLUSH
+ DB_NOLOCKING
+ DB_NOMMAP
+ DB_NOORDERCHK
+ DB_NOOVERWRITE
+ DB_NOPANIC
+ DB_NORECURSE
+ DB_NOSERVER
+ DB_NOSERVER_HOME
+ DB_NOSERVER_ID
+ DB_NOSYNC
+ DB_NOTFOUND
+ DB_NO_AUTO_COMMIT
+ DB_NO_CHECKPOINT
+ DB_ODDFILESIZE
+ DB_OK_BTREE
+ DB_OK_HASH
+ DB_OK_HEAP
+ DB_OK_QUEUE
+ DB_OK_RECNO
+ DB_OLD_VERSION
+ DB_OPEN_CALLED
+ DB_OPFLAGS_MASK
+ DB_ORDERCHKONLY
+ DB_OVERWRITE
+ DB_OVERWRITE_DUP
+ DB_PAD
+ DB_PAGEYIELD
+ DB_PAGE_LOCK
+ DB_PAGE_NOTFOUND
+ DB_PANIC_ENVIRONMENT
+ DB_PERMANENT
+ DB_POSITION
+ DB_POSITIONI
+ DB_PREV
+ DB_PREV_DUP
+ DB_PREV_NODUP
+ DB_PRINTABLE
+ DB_PRIORITY_DEFAULT
+ DB_PRIORITY_HIGH
+ DB_PRIORITY_LOW
+ DB_PRIORITY_UNCHANGED
+ DB_PRIORITY_VERY_HIGH
+ DB_PRIORITY_VERY_LOW
+ DB_PRIVATE
+ DB_PR_HEADERS
+ DB_PR_PAGE
+ DB_PR_RECOVERYTEST
+ DB_QAMMAGIC
+ DB_QAMOLDVER
+ DB_QAMVERSION
+ DB_QUEUE
+ DB_RDONLY
+ DB_RDWRMASTER
+ DB_READ_COMMITTED
+ DB_READ_UNCOMMITTED
+ DB_RECNO
+ DB_RECNUM
+ DB_RECORDCOUNT
+ DB_RECORD_LOCK
+ DB_RECOVER
+ DB_RECOVER_FATAL
+ DB_REGION_ANON
+ DB_REGION_INIT
+ DB_REGION_MAGIC
+ DB_REGION_NAME
+ DB_REGISTER
+ DB_REGISTERED
+ DB_RENAMEMAGIC
+ DB_RENUMBER
+ DB_REPFLAGS_MASK
+ DB_REPMGR_ACKS_ALL
+ DB_REPMGR_ACKS_ALL_AVAILABLE
+ DB_REPMGR_ACKS_ALL_PEERS
+ DB_REPMGR_ACKS_NONE
+ DB_REPMGR_ACKS_ONE
+ DB_REPMGR_ACKS_ONE_PEER
+ DB_REPMGR_ACKS_QUORUM
+ DB_REPMGR_CONF_2SITE_STRICT
+ DB_REPMGR_CONF_ELECTIONS
+ DB_REPMGR_CONNECTED
+ DB_REPMGR_DISCONNECTED
+ DB_REPMGR_ISPEER
+ DB_REPMGR_NEED_RESPONSE
+ DB_REPMGR_PEER
+ DB_REP_ACK_TIMEOUT
+ DB_REP_ANYWHERE
+ DB_REP_BULKOVF
+ DB_REP_CHECKPOINT_DELAY
+ DB_REP_CLIENT
+ DB_REP_CONF_AUTOINIT
+ DB_REP_CONF_AUTOROLLBACK
+ DB_REP_CONF_BULK
+ DB_REP_CONF_DELAYCLIENT
+ DB_REP_CONF_INMEM
+ DB_REP_CONF_LEASE
+ DB_REP_CONF_NOAUTOINIT
+ DB_REP_CONF_NOWAIT
+ DB_REP_CONNECTION_RETRY
+ DB_REP_CREATE
+ DB_REP_DEFAULT_PRIORITY
+ DB_REP_DUPMASTER
+ DB_REP_EGENCHG
+ DB_REP_ELECTION
+ DB_REP_ELECTION_RETRY
+ DB_REP_ELECTION_TIMEOUT
+ DB_REP_FULL_ELECTION
+ DB_REP_FULL_ELECTION_TIMEOUT
+ DB_REP_HANDLE_DEAD
+ DB_REP_HEARTBEAT_MONITOR
+ DB_REP_HEARTBEAT_SEND
+ DB_REP_HOLDELECTION
+ DB_REP_IGNORE
+ DB_REP_ISPERM
+ DB_REP_JOIN_FAILURE
+ DB_REP_LEASE_EXPIRED
+ DB_REP_LEASE_TIMEOUT
+ DB_REP_LOCKOUT
+ DB_REP_LOGREADY
+ DB_REP_LOGSONLY
+ DB_REP_MASTER
+ DB_REP_NEWMASTER
+ DB_REP_NEWSITE
+ DB_REP_NOBUFFER
+ DB_REP_NOTPERM
+ DB_REP_OUTDATED
+ DB_REP_PAGEDONE
+ DB_REP_PAGELOCKED
+ DB_REP_PERMANENT
+ DB_REP_REREQUEST
+ DB_REP_STARTUPDONE
+ DB_REP_UNAVAIL
+ DB_REP_WOULDROLLBACK
+ DB_REVSPLITOFF
+ DB_RMW
+ DB_RPCCLIENT
+ DB_RPC_SERVERPROG
+ DB_RPC_SERVERVERS
+ DB_RUNRECOVERY
+ DB_SALVAGE
+ DB_SA_SKIPFIRSTKEY
+ DB_SA_UNKNOWNKEY
+ DB_SECONDARY_BAD
+ DB_SEQUENCE_OLDVER
+ DB_SEQUENCE_VERSION
+ DB_SEQUENTIAL
+ DB_SEQ_DEC
+ DB_SEQ_INC
+ DB_SEQ_RANGE_SET
+ DB_SEQ_WRAP
+ DB_SEQ_WRAPPED
+ DB_SET
+ DB_SET_LOCK_TIMEOUT
+ DB_SET_LTE
+ DB_SET_RANGE
+ DB_SET_RECNO
+ DB_SET_REG_TIMEOUT
+ DB_SET_TXN_NOW
+ DB_SET_TXN_TIMEOUT
+ DB_SHALLOW_DUP
+ DB_SNAPSHOT
+ DB_SPARE_FLAG
+ DB_STAT_ALL
+ DB_STAT_ALLOC
+ DB_STAT_CLEAR
+ DB_STAT_LOCK_CONF
+ DB_STAT_LOCK_LOCKERS
+ DB_STAT_LOCK_OBJECTS
+ DB_STAT_LOCK_PARAMS
+ DB_STAT_MEMP_HASH
+ DB_STAT_MEMP_NOERROR
+ DB_STAT_NOERROR
+ DB_STAT_SUBSYSTEM
+ DB_STAT_SUMMARY
+ DB_ST_DUPOK
+ DB_ST_DUPSET
+ DB_ST_DUPSORT
+ DB_ST_IS_RECNO
+ DB_ST_OVFL_LEAF
+ DB_ST_RECNUM
+ DB_ST_RELEN
+ DB_ST_TOPLEVEL
+ DB_SURPRISE_KID
+ DB_SWAPBYTES
+ DB_SYSTEM_MEM
+ DB_TEMPORARY
+ DB_TEST_ELECTINIT
+ DB_TEST_ELECTSEND
+ DB_TEST_ELECTVOTE1
+ DB_TEST_ELECTVOTE2
+ DB_TEST_ELECTWAIT1
+ DB_TEST_ELECTWAIT2
+ DB_TEST_POSTDESTROY
+ DB_TEST_POSTLOG
+ DB_TEST_POSTLOGMETA
+ DB_TEST_POSTOPEN
+ DB_TEST_POSTRENAME
+ DB_TEST_POSTSYNC
+ DB_TEST_PREDESTROY
+ DB_TEST_PREOPEN
+ DB_TEST_PRERENAME
+ DB_TEST_RECYCLE
+ DB_TEST_SUBDB_LOCKS
+ DB_THREAD
+ DB_THREADID_STRLEN
+ DB_TIMEOUT
+ DB_TIME_NOTGRANTED
+ DB_TRUNCATE
+ DB_TXNMAGIC
+ DB_TXNVERSION
+ DB_TXN_ABORT
+ DB_TXN_APPLY
+ DB_TXN_BACKWARD_ROLL
+ DB_TXN_BULK
+ DB_TXN_CKP
+ DB_TXN_FAMILY
+ DB_TXN_FORWARD_ROLL
+ DB_TXN_LOCK
+ DB_TXN_LOCK_2PL
+ DB_TXN_LOCK_MASK
+ DB_TXN_LOCK_OPTIMIST
+ DB_TXN_LOCK_OPTIMISTIC
+ DB_TXN_LOG_MASK
+ DB_TXN_LOG_REDO
+ DB_TXN_LOG_UNDO
+ DB_TXN_LOG_UNDOREDO
+ DB_TXN_LOG_VERIFY
+ DB_TXN_NOSYNC
+ DB_TXN_NOT_DURABLE
+ DB_TXN_NOWAIT
+ DB_TXN_OPENFILES
+ DB_TXN_POPENFILES
+ DB_TXN_PRINT
+ DB_TXN_REDO
+ DB_TXN_SNAPSHOT
+ DB_TXN_SYNC
+ DB_TXN_TOKEN_SIZE
+ DB_TXN_UNDO
+ DB_TXN_WAIT
+ DB_TXN_WRITE_NOSYNC
+ DB_UNKNOWN
+ DB_UNREF
+ DB_UPDATE_SECONDARY
+ DB_UPGRADE
+ DB_USERCOPY_GETDATA
+ DB_USERCOPY_SETDATA
+ DB_USE_ENVIRON
+ DB_USE_ENVIRON_ROOT
+ DB_VERB_BACKUP
+ DB_VERB_CHKPOINT
+ DB_VERB_DEADLOCK
+ DB_VERB_FILEOPS
+ DB_VERB_FILEOPS_ALL
+ DB_VERB_RECOVERY
+ DB_VERB_REGISTER
+ DB_VERB_REPLICATION
+ DB_VERB_REPMGR_CONNFAIL
+ DB_VERB_REPMGR_MISC
+ DB_VERB_REP_ELECT
+ DB_VERB_REP_LEASE
+ DB_VERB_REP_MISC
+ DB_VERB_REP_MSGS
+ DB_VERB_REP_SYNC
+ DB_VERB_REP_SYSTEM
+ DB_VERB_REP_TEST
+ DB_VERB_WAITSFOR
+ DB_VERIFY
+ DB_VERIFY_BAD
+ DB_VERIFY_FATAL
+ DB_VERIFY_PARTITION
+ DB_VERSION_FAMILY
+ DB_VERSION_FULL_STRING
+ DB_VERSION_MAJOR
+ DB_VERSION_MINOR
+ DB_VERSION_MISMATCH
+ DB_VERSION_PATCH
+ DB_VERSION_RELEASE
+ DB_VERSION_STRING
+ DB_VRFY_FLAGMASK
+ DB_WRITECURSOR
+ DB_WRITELOCK
+ DB_WRITEOPEN
+ DB_WRNOSYNC
+ DB_XA_CREATE
+ DB_XIDDATASIZE
+ DB_YIELDCPU
+ DB_debug_FLAG
+ DB_user_BEGIN
+ LOGREC_ARG
+ LOGREC_DATA
+ LOGREC_DB
+ LOGREC_DBOP
+ LOGREC_DBT
+ LOGREC_Done
+ LOGREC_HDR
+ LOGREC_LOCKS
+ LOGREC_OP
+ LOGREC_PGDBT
+ LOGREC_PGDDBT
+ LOGREC_PGLIST
+ LOGREC_POINTER
+ LOGREC_TIME
+ );
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+#bootstrap BerkeleyDB $VERSION;
+if ($use_XSLoader)
+ { XSLoader::load("BerkeleyDB", $VERSION)}
+else
+ { bootstrap BerkeleyDB $VERSION }
+
+# Preloaded methods go here.
+
+
+sub ParseParameters($@)
+{
+ my ($default, @rest) = @_ ;
+ my (%got) = %$default ;
+ my (@Bad) ;
+ my ($key, $value) ;
+ my $sub = (caller(1))[3] ;
+ my %options = () ;
+ local ($Carp::CarpLevel) = 1 ;
+
+ # allow the options to be passed as a hash reference or
+ # as the complete hash.
+ if (@rest == 1) {
+
+ croak "$sub: parameter is not a reference to a hash"
+ if ref $rest[0] ne "HASH" ;
+
+ %options = %{ $rest[0] } ;
+ }
+ elsif (@rest >= 2 && @rest % 2 == 0) {
+ %options = @rest ;
+ }
+ elsif (@rest > 0) {
+ croak "$sub: malformed option list";
+ }
+
+ while (($key, $value) = each %options)
+ {
+ $key =~ s/^-// ;
+
+ if (exists $default->{$key})
+ { $got{$key} = $value }
+ else
+ { push (@Bad, $key) }
+ }
+
+ if (@Bad) {
+ my ($bad) = join(", ", @Bad) ;
+ croak "unknown key value(s) $bad" ;
+ }
+
+ return \%got ;
+}
+
+sub parseEncrypt
+{
+ my $got = shift ;
+
+
+ if (defined $got->{Encrypt}) {
+ croak("Encrypt parameter must be a hash reference")
+ if !ref $got->{Encrypt} || ref $got->{Encrypt} ne 'HASH' ;
+
+ my %config = %{ $got->{Encrypt} } ;
+
+ my $p = BerkeleyDB::ParseParameters({
+ Password => undef,
+ Flags => undef,
+ }, %config);
+
+ croak("Must specify Password and Flags with Encrypt parameter")
+ if ! (defined $p->{Password} && defined $p->{Flags});
+
+ $got->{"Enc_Passwd"} = $p->{Password};
+ $got->{"Enc_Flags"} = $p->{Flags};
+ }
+}
+
+use UNIVERSAL ;
+
+sub env_remove
+{
+ # Usage:
+ #
+ # $env = BerkeleyDB::env_remove
+ # [ -Home => $path, ]
+ # [ -Config => { name => value, name => value }
+ # [ -Flags => DB_INIT_LOCK| ]
+ # ;
+
+ my $got = BerkeleyDB::ParseParameters({
+ Home => undef,
+ Flags => 0,
+ Config => undef,
+ }, @_) ;
+
+ if (defined $got->{Config}) {
+ croak("Config parameter must be a hash reference")
+ if ! ref $got->{Config} eq 'HASH' ;
+
+ @BerkeleyDB::a = () ;
+ my $k = "" ; my $v = "" ;
+ while (($k, $v) = each %{$got->{Config}}) {
+ push @BerkeleyDB::a, "$k\t$v" ;
+ }
+
+ $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef)
+ if @BerkeleyDB::a ;
+ }
+
+ return _env_remove($got) ;
+}
+
+sub db_remove
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Flags => 0,
+ Env => undef,
+ Txn => undef,
+ }, @_) ;
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ return _db_remove($got);
+}
+
+sub db_rename
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Newname => undef,
+ Flags => 0,
+ Env => undef,
+ Txn => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ #croak("Must specify a Subname")
+ #if ! defined $got->{Subname} ;
+
+ croak("Must specify a Newname")
+ if ! defined $got->{Newname} ;
+
+ return _db_rename($got);
+}
+
+sub db_verify
+{
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ Filename => undef,
+ Subname => undef,
+ Outfile => undef,
+ Flags => 0,
+ Env => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Must specify a filename")
+ if ! defined $got->{Filename} ;
+
+ return _db_verify($got);
+}
+
+package BerkeleyDB::Env ;
+
+use UNIVERSAL ;
+use Carp ;
+use IO::File;
+use vars qw( %valid_config_keys ) ;
+
+sub isaFilehandle
+{
+ my $fh = shift ;
+
+ return ((UNIVERSAL::isa($fh,'GLOB') or UNIVERSAL::isa(\$fh,'GLOB')) and defined fileno($fh) )
+
+}
+
+%valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR
+DB_TMP_DIR ) ;
+
+sub new
+{
+ # Usage:
+ #
+ # $env = new BerkeleyDB::Env
+ # [ -Home => $path, ]
+ # [ -Mode => mode, ]
+ # [ -Config => { name => value, name => value }
+ # [ -ErrFile => filename, ]
+ # [ -ErrPrefix => "string", ]
+ # [ -Flags => DB_INIT_LOCK| ]
+ # [ -Set_Flags => $flags,]
+ # [ -Cachesize => number ]
+ # [ -LockDetect => ]
+ # [ -Verbose => boolean ]
+ # [ -Encrypt => { Password => string, Flags => value}
+ #
+ # ;
+
+ my $pkg = shift ;
+ my $got = BerkeleyDB::ParseParameters({
+ Home => undef,
+ Server => undef,
+ Mode => 0666,
+ ErrFile => undef,
+ MsgFile => undef,
+ ErrPrefix => undef,
+ Flags => 0,
+ SetFlags => 0,
+ Cachesize => 0,
+ LockDetect => 0,
+ TxMax => 0,
+ LogConfig => 0,
+ MaxLockers => 0,
+ MaxLocks => 0,
+ MaxObjects => 0,
+ Verbose => 0,
+ Config => undef,
+ Encrypt => undef,
+ SharedMemKey => undef,
+ Set_Lk_Exclusive => undef,
+ ThreadCount => 0,
+ }, @_) ;
+
+ my $errfile = $got->{ErrFile} ;
+ if (defined $got->{ErrFile}) {
+ if (!isaFilehandle($got->{ErrFile})) {
+ my $handle = new IO::File ">$got->{ErrFile}"
+ or croak "Cannot open file $got->{ErrFile}: $!\n" ;
+ $errfile = $got->{ErrFile} = $handle ;
+ }
+ }
+
+ if (defined $got->{MsgFile}) {
+ my $msgfile = $got->{MsgFile} ;
+ if (!isaFilehandle($msgfile)) {
+ my $handle = new IO::File ">$msgfile"
+ or croak "Cannot open file $msgfile: $!\n" ;
+ $got->{MsgFile} = $handle ;
+ }
+ }
+
+ my %config ;
+ if (defined $got->{Config}) {
+ croak("Config parameter must be a hash reference")
+ if ! ref $got->{Config} eq 'HASH' ;
+
+ %config = %{ $got->{Config} } ;
+ @BerkeleyDB::a = () ;
+ my $k = "" ; my $v = "" ;
+ while (($k, $v) = each %config) {
+ if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){
+ $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ;
+ croak $BerkeleyDB::Error ;
+ }
+ push @BerkeleyDB::a, "$k\t$v" ;
+ $got->{$k} = $v;
+ }
+
+ $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef)
+ if @BerkeleyDB::a ;
+ }
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_appinit($pkg, $got, $errfile);
+ my $obj ;
+ $obj = bless [$addr] , $pkg if $addr ;
+# if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) {
+# my ($k, $v);
+# while (($k, $v) = each %config) {
+# if ($k eq 'DB_DATA_DIR')
+# { $obj->set_data_dir($v) }
+# elsif ($k eq 'DB_LOG_DIR')
+# { $obj->set_lg_dir($v) }
+# elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR')
+# { $obj->set_tmp_dir($v) }
+# else {
+# $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ;
+# croak $BerkeleyDB::Error
+# }
+# }
+# }
+ return $obj ;
+}
+
+
+sub TxnMgr
+{
+ my $env = shift ;
+ my ($addr) = $env->_TxnMgr() ;
+ my $obj ;
+ $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ;
+ return $obj ;
+}
+
+sub txn_begin
+{
+ my $env = shift ;
+ my ($addr) = $env->_txn_begin(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ;
+ return $obj ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+sub STORABLE_freeze
+{
+ my $type = ref shift;
+ croak "Cannot freeze $type object\n";
+}
+
+sub STORABLE_thaw
+{
+ my $type = ref shift;
+ croak "Cannot thaw $type object\n";
+}
+
+package BerkeleyDB::Hash ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Hash specific
+ Ffactor => 0,
+ Nelem => 0,
+ Hash => undef,
+ DupCompare => undef,
+
+ # BerkeleyDB specific
+ ReadKey => undef,
+ WriteKey => undef,
+ ReadValue => undef,
+ WriteValue => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_open_hash($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*TIEHASH = \&new ;
+
+
+package BerkeleyDB::Btree ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Btree specific
+ Minkey => 0,
+ Compare => undef,
+ DupCompare => undef,
+ Prefix => undef,
+ set_bt_compress => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+# if (defined $got->{set_bt_compress} )
+# {
+#
+# croak("-set_bt_compress needs a reference to a 2-element array")
+# if $got->{set_bt_compress} !~ /ARRAY/ ||
+#
+# croak("-set_bt_compress needs a reference to a 2-element array")
+# if $got->{set_bt_compress} !~ /ARRAY/ ||
+# @{ $got->{set_bt_compress} } != 2;
+#
+# $got->{"_btcompress1"} = $got->{set_bt_compress}[0]
+# if defined $got->{set_bt_compress}[0];
+#
+# $got->{"_btcompress2"} = $got->{set_bt_compress}[1]
+# if defined $got->{set_bt_compress}[1];
+# }
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_open_btree($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ;
+
+package BerkeleyDB::Heap ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Heap specific
+ HeapSize => undef,
+ HeapSizeGb => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+# if (defined $got->{HeapSize} )
+# {
+#
+# croak("-HeapSize needs a reference to a 2-element array")
+# if $got->{HeapSize} !~ /ARRAY/ ||
+#
+# croak("-HeapSize needs a reference to a 2-element array")
+# if $got->{HeapSize} !~ /ARRAY/ ||
+# @{ $got->{set_bt_compress} } != 2;
+#
+# $got->{"HeapSize"} = $got->{HeapSize}[0]
+# if defined $got->{HeapSize}[0];
+#
+# $got->{"HeapSize"} = $got->{HeapSize}[1]
+# if defined $got->{HeapSize}[1];
+# }
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr) = _db_open_heap($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+sub TIEHASH
+{
+ die "Tied Hash interface not supported with BerkeleyDB::Heap\n" ;
+}
+
+
+package BerkeleyDB::Recno ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Recno specific
+ Delim => undef,
+ Len => undef,
+ Pad => undef,
+ Source => undef,
+ ArrayBase => 1, # lowest index in array
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("Tie needs a reference to an array")
+ if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+
+ croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
+ if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
+
+
+ BerkeleyDB::parseEncrypt($got);
+
+ $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;
+
+ my ($addr) = _db_open_recno($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ;
+*BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ;
+
+package BerkeleyDB::Queue ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ # Queue specific
+ Len => undef,
+ Pad => undef,
+ ArrayBase => 1, # lowest index in array
+ ExtentSize => undef,
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("Tie needs a reference to an array")
+ if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+
+ croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
+ if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;
+
+ my ($addr) = _db_open_queue($self, $got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr] , $self ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+*BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ;
+
+sub UNSHIFT
+{
+ my $self = shift;
+ croak "unshift is unsupported with Queue databases";
+}
+
+## package BerkeleyDB::Text ;
+##
+## use vars qw(@ISA) ;
+## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+## use UNIVERSAL ;
+## use Carp ;
+##
+## sub new
+## {
+## my $self = shift ;
+## my $got = BerkeleyDB::ParseParameters(
+## {
+## # Generic Stuff
+## Filename => undef,
+## #Flags => BerkeleyDB::DB_CREATE(),
+## Flags => 0,
+## Property => 0,
+## Mode => 0666,
+## Cachesize => 0,
+## Lorder => 0,
+## Pagesize => 0,
+## Env => undef,
+## #Tie => undef,
+## Txn => undef,
+##
+## # Recno specific
+## Delim => undef,
+## Len => undef,
+## Pad => undef,
+## Btree => undef,
+## }, @_) ;
+##
+## croak("Env not of type BerkeleyDB::Env")
+## if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
+##
+## croak("Txn not of type BerkeleyDB::Txn")
+## if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
+##
+## croak("-Tie needs a reference to an array")
+## if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
+##
+## # rearange for recno
+## $got->{Source} = $got->{Filename} if defined $got->{Filename} ;
+## delete $got->{Filename} ;
+## $got->{Fname} = $got->{Btree} if defined $got->{Btree} ;
+## return BerkeleyDB::Recno::_db_open_recno($self, $got);
+## }
+##
+## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ;
+## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ;
+
+package BerkeleyDB::Unknown ;
+
+use vars qw(@ISA) ;
+@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
+use UNIVERSAL ;
+use Carp ;
+
+sub new
+{
+ my $self = shift ;
+ my $got = BerkeleyDB::ParseParameters(
+ {
+ # Generic Stuff
+ Filename => undef,
+ Subname => undef,
+ #Flags => BerkeleyDB::DB_CREATE(),
+ Flags => 0,
+ Property => 0,
+ Mode => 0666,
+ Cachesize => 0,
+ Lorder => 0,
+ Pagesize => 0,
+ Env => undef,
+ #Tie => undef,
+ Txn => undef,
+ Encrypt => undef,
+
+ }, @_) ;
+
+ croak("Env not of type BerkeleyDB::Env")
+ if defined $got->{Env} and ! UNIVERSAL::isa($got->{Env},'BerkeleyDB::Env');
+
+ croak("Txn not of type BerkeleyDB::Txn")
+ if defined $got->{Txn} and ! UNIVERSAL::isa($got->{Txn},'BerkeleyDB::Txn');
+
+ croak("-Tie needs a reference to a hash")
+ if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
+
+ BerkeleyDB::parseEncrypt($got);
+
+ my ($addr, $type) = _db_open_unknown($got);
+ my $obj ;
+ if ($addr) {
+ $obj = bless [$addr], "BerkeleyDB::$type" ;
+ push @{ $obj }, $got->{Env} if $got->{Env} ;
+ $obj->Txn($got->{Txn})
+ if $got->{Txn} ;
+ }
+ return $obj ;
+}
+
+
+package BerkeleyDB::_tiedHash ;
+
+use Carp ;
+
+#sub TIEHASH
+#{
+# my $self = shift ;
+# my $db_object = shift ;
+#
+#print "Tiehash REF=[$self] [" . (ref $self) . "]\n" ;
+#
+# return bless { Obj => $db_object}, $self ;
+#}
+
+sub Tie
+{
+ # Usage:
+ #
+ # $db->Tie \%hash ;
+ #
+
+ my $self = shift ;
+
+ #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;
+
+ croak("usage \$x->Tie \\%hash\n") unless @_ ;
+ my $ref = shift ;
+
+ croak("Tie needs a reference to a hash")
+ if defined $ref and $ref !~ /HASH/ ;
+
+ #tie %{ $ref }, ref($self), $self ;
+ tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ;
+ return undef ;
+}
+
+
+sub TIEHASH
+{
+ my $self = shift ;
+ my $db_object = shift ;
+ #return bless $db_object, 'BerkeleyDB::Common' ;
+ return $db_object ;
+}
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ $self->db_put($key, $value) ;
+}
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) ;
+
+ return $value ;
+}
+
+sub EXISTS
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) == 0 ;
+}
+
+sub DELETE
+{
+ my $self = shift ;
+ my $key = shift ;
+ $self->db_del($key) ;
+}
+
+sub CLEAR_old
+{
+ my $self = shift ;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0)
+ { $cursor->c_del() }
+}
+
+sub CLEAR_new
+{
+ my $self = shift ;
+ $self->truncate(my $count);
+}
+
+*CLEAR = $BerkeleyDB::db_version < 4 ? \&CLEAR_old : \&CLEAR_new ;
+
+#sub DESTROY
+#{
+# my $self = shift ;
+# print "BerkeleyDB::_tieHash::DESTROY\n" ;
+# $self->{Cursor}->c_close() if $self->{Cursor} ;
+#}
+
+package BerkeleyDB::_tiedArray ;
+
+use Carp ;
+
+sub Tie
+{
+ # Usage:
+ #
+ # $db->Tie \@array ;
+ #
+
+ my $self = shift ;
+
+ #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;
+
+ croak("usage \$x->Tie \\%hash\n") unless @_ ;
+ my $ref = shift ;
+
+ croak("Tie needs a reference to an array")
+ if defined $ref and $ref !~ /ARRAY/ ;
+
+ #tie %{ $ref }, ref($self), $self ;
+ tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ;
+ return undef ;
+}
+
+
+#sub TIEARRAY
+#{
+# my $self = shift ;
+# my $db_object = shift ;
+#
+#print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ;
+#
+# return bless { Obj => $db_object}, $self ;
+#}
+
+sub TIEARRAY
+{
+ my $self = shift ;
+ my $db_object = shift ;
+ #return bless $db_object, 'BerkeleyDB::Common' ;
+ return $db_object ;
+}
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ $self->db_put($key, $value) ;
+}
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = undef ;
+ $self->db_get($key, $value) ;
+
+ return $value ;
+}
+
+*CLEAR = \&BerkeleyDB::_tiedHash::CLEAR ;
+*FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ;
+*NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ;
+
+sub EXTEND {} # don't do anything with EXTEND
+
+
+sub SHIFT
+{
+ my $self = shift;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ;
+ return undef if $cursor->c_del() != 0 ;
+
+ return $value ;
+}
+
+
+sub UNSHIFT
+{
+ my $self = shift;
+ if (@_)
+ {
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ;
+ if ($status == 0)
+ {
+ foreach $value (reverse @_)
+ {
+ $key = 0 ;
+ $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ;
+ }
+ }
+ elsif ($status == BerkeleyDB::DB_NOTFOUND())
+ {
+ $key = 0 ;
+ foreach $value (@_)
+ {
+ $self->db_put($key++, $value) ;
+ }
+ }
+ }
+}
+
+sub PUSH
+{
+ my $self = shift;
+ if (@_)
+ {
+ my ($key, $value) = (-1, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ;
+ if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND())
+ {
+ $key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ;
+ foreach $value (@_)
+ {
+ ++ $key ;
+ $status = $self->db_put($key, $value) ;
+ }
+ }
+
+# can use this when DB_APPEND is fixed.
+# foreach $value (@_)
+# {
+# my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ;
+#print "[$status]\n" ;
+# }
+ }
+}
+
+sub POP
+{
+ my $self = shift;
+ my ($key, $value) = (0, 0) ;
+ my $cursor = $self->_db_write_cursor() ;
+ return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ;
+ return undef if $cursor->c_del() != 0 ;
+
+ return $value ;
+}
+
+sub SPLICE
+{
+ my $self = shift;
+ croak "SPLICE is not implemented yet" ;
+}
+
+*shift = \&SHIFT ;
+*unshift = \&UNSHIFT ;
+*push = \&PUSH ;
+*pop = \&POP ;
+*clear = \&CLEAR ;
+*length = \&FETCHSIZE ;
+
+sub STORESIZE
+{
+ croak "STORESIZE is not implemented yet" ;
+#print "STORESIZE @_\n" ;
+# my $self = shift;
+# my $length = shift ;
+# my $current_length = $self->FETCHSIZE() ;
+#print "length is $current_length\n";
+#
+# if ($length < $current_length) {
+#print "Make smaller $length < $current_length\n" ;
+# my $key ;
+# for ($key = $current_length - 1 ; $key >= $length ; -- $key)
+# { $self->db_del($key) }
+# }
+# elsif ($length > $current_length) {
+#print "Make larger $length > $current_length\n" ;
+# $self->db_put($length-1, "") ;
+# }
+# else { print "stay the same\n" }
+
+}
+
+
+
+#sub DESTROY
+#{
+# my $self = shift ;
+# print "BerkeleyDB::_tieArray::DESTROY\n" ;
+#}
+
+
+package BerkeleyDB::Common ;
+
+
+use Carp ;
+
+
+sub STORABLE_freeze
+{
+ my $type = ref shift;
+ croak "Cannot freeze $type object\n";
+}
+
+sub STORABLE_thaw
+{
+ my $type = ref shift;
+ croak "Cannot thaw $type object\n";
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+sub Env
+{
+ my $self = shift ;
+ $self->[1] ;
+}
+
+sub Txn
+{
+ my $self = shift ;
+ my $txn = shift ;
+ #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ;
+ if ($txn) {
+ $self->_Txn($txn) ;
+ push @{ $txn }, $self ;
+ }
+ else {
+ $self->_Txn() ;
+ }
+ #print "end BerkeleyDB::Common::Txn \n";
+}
+
+
+sub get_dup
+{
+ croak "Usage: \$db->get_dup(key [,flag])\n"
+ unless @_ == 2 or @_ == 3 ;
+
+ my $db = shift ;
+ my $key = shift ;
+ my $flag = shift ;
+ my $value = 0 ;
+ my $origkey = $key ;
+ my $wantarray = wantarray ;
+ my %values = () ;
+ my @values = () ;
+ my $counter = 0 ;
+ my $status = 0 ;
+ my $cursor = $db->db_cursor() ;
+
+ # iterate through the database until either EOF ($status == 0)
+ # or a different key is encountered ($key ne $origkey).
+ for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ;
+ $status == 0 and $key eq $origkey ;
+ $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) {
+ # save the value or count number of matches
+ if ($wantarray) {
+ if ($flag)
+ { ++ $values{$value} }
+ else
+ { push (@values, $value) }
+ }
+ else
+ { ++ $counter }
+
+ }
+
+ return ($wantarray ? ($flag ? %values : @values) : $counter) ;
+}
+
+sub db_cursor
+{
+ my $db = shift ;
+ my ($addr) = $db->_db_cursor(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub _db_write_cursor
+{
+ my $db = shift ;
+ my ($addr) = $db->__db_write_cursor(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub db_join
+{
+ croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)'
+ if @_ < 2 || @_ > 3 ;
+ my $db = shift ;
+ croak 'db_join: first parameter is not an array reference'
+ if ! ref $_[0] || ref $_[0] ne 'ARRAY';
+ my ($addr) = $db->_db_join(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+package BerkeleyDB::Cursor ;
+
+sub c_close
+{
+ my $cursor = shift ;
+ $cursor->[1] = "" ;
+ return $cursor->_c_close() ;
+}
+
+sub c_dup
+{
+ my $cursor = shift ;
+ my ($addr) = $cursor->_c_dup(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ;
+ return $obj ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+package BerkeleyDB::TxnMgr ;
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->_DESTROY() ;
+}
+
+sub txn_begin
+{
+ my $txnmgr = shift ;
+ my ($addr) = $txnmgr->_txn_begin(@_) ;
+ my $obj ;
+ $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ;
+ return $obj ;
+}
+
+package BerkeleyDB::Txn ;
+
+sub Txn
+{
+ my $self = shift ;
+ my $db ;
+ # keep a reference to each db in the txn object
+ foreach $db (@_) {
+ $db->_Txn($self) ;
+ push @{ $self}, $db ;
+ }
+}
+
+sub txn_commit
+{
+ my $self = shift ;
+ $self->disassociate() ;
+ my $status = $self->_txn_commit() ;
+ return $status ;
+}
+
+sub txn_abort
+{
+ my $self = shift ;
+ $self->disassociate() ;
+ my $status = $self->_txn_abort() ;
+ return $status ;
+}
+
+sub disassociate
+{
+ my $self = shift ;
+ my $db ;
+ while ( @{ $self } > 2) {
+ $db = pop @{ $self } ;
+ $db->Txn() ;
+ }
+ #print "end disassociate\n" ;
+}
+
+
+sub DESTROY
+{
+ my $self = shift ;
+
+ $self->disassociate() ;
+ # first close the close the transaction
+ $self->_DESTROY() ;
+}
+
+package BerkeleyDB::CDS::Lock;
+
+use vars qw(%Object %Count);
+use Carp;
+
+sub BerkeleyDB::Common::cds_lock
+{
+ my $db = shift ;
+
+ # fatal error if database not opened in CDS mode
+ croak("CDS not enabled for this database\n")
+ if ! $db->cds_enabled();
+
+ if ( ! defined $Object{"$db"})
+ {
+ $Object{"$db"} = $db->_db_write_cursor()
+ || return undef ;
+ }
+
+ ++ $Count{"$db"} ;
+
+ return bless [$db, 1], "BerkeleyDB::CDS::Lock" ;
+}
+
+sub cds_unlock
+{
+ my $self = shift ;
+ my $db = $self->[0] ;
+
+ if ($self->[1])
+ {
+ $self->[1] = 0 ;
+ -- $Count{"$db"} if $Count{"$db"} > 0 ;
+
+ if ($Count{"$db"} == 0)
+ {
+ $Object{"$db"}->c_close() ;
+ undef $Object{"$db"};
+ }
+
+ return 1 ;
+ }
+
+ return undef ;
+}
+
+sub DESTROY
+{
+ my $self = shift ;
+ $self->cds_unlock() ;
+}
+
+package BerkeleyDB::Term ;
+
+END
+{
+ close_everything() ;
+}
+
+
+package BerkeleyDB ;
+
+
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+
+
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB.pod b/lang/perl/BerkeleyDB/BerkeleyDB.pod
new file mode 100644
index 00000000..19fcba83
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB.pod
@@ -0,0 +1,2590 @@
+=head1 NAME
+
+BerkeleyDB - Perl extension for Berkeley DB version 2, 3, 4 or 5
+
+=head1 SYNOPSIS
+
+ use BerkeleyDB;
+
+ $env = new BerkeleyDB::Env [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Hash', [OPTIONS] ;
+ $db = new BerkeleyDB::Hash [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Btree', [OPTIONS] ;
+ $db = new BerkeleyDB::Btree [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Recno', [OPTIONS] ;
+ $db = new BerkeleyDB::Recno [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Queue', [OPTIONS] ;
+ $db = new BerkeleyDB::Queue [OPTIONS] ;
+
+ $db = new BerkeleyDB::Heap [OPTIONS] ;
+
+ $db = new BerkeleyDB::Unknown [OPTIONS] ;
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+ $hash{$key} = $value ;
+ $value = $hash{$key} ;
+ each %hash ;
+ keys %hash ;
+ values %hash ;
+
+ $env = $db->Env()
+ $status = $db->db_get()
+ $status = $db->db_exists() ;
+ $status = $db->db_put() ;
+ $status = $db->db_del() ;
+ $status = $db->db_sync() ;
+ $status = $db->db_close() ;
+ $status = $db->db_pget()
+ $hash_ref = $db->db_stat() ;
+ $status = $db->db_key_range();
+ $type = $db->type() ;
+ $status = $db->status() ;
+ $boolean = $db->byteswapped() ;
+ $status = $db->truncate($count) ;
+ $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+ $bool = $env->cds_enabled();
+ $bool = $db->cds_enabled();
+ $lock = $db->cds_lock();
+ $lock->cds_unlock();
+
+ ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+ ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+ $cursor = $db->db_cursor([$flags]) ;
+ $newcursor = $cursor->c_dup([$flags]);
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_put() ;
+ $status = $cursor->c_del() ;
+ $status = $cursor->c_count() ;
+ $status = $cursor->c_pget() ;
+ $status = $cursor->status() ;
+ $status = $cursor->c_close() ;
+
+ $cursor = $db->db_join() ;
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_close() ;
+
+ $status = $env->txn_checkpoint()
+ $hash_ref = $env->txn_stat()
+ $status = $env->set_mutexlocks()
+ $status = $env->set_flags()
+ $status = $env->set_timeout()
+ $status = $env->lock_detect()
+ $status = $env->lsn_reset()
+
+ $txn = $env->txn_begin() ;
+ $db->Txn($txn);
+ $txn->Txn($db1, $db2,...);
+ $status = $txn->txn_prepare()
+ $status = $txn->txn_commit()
+ $status = $txn->txn_abort()
+ $status = $txn->txn_id()
+ $status = $txn->txn_discard()
+ $status = $txn->set_timeout()
+
+ $status = $env->set_lg_dir();
+ $status = $env->set_lg_bsize();
+ $status = $env->set_lg_max();
+
+ $status = $env->set_data_dir() ;
+ $status = $env->set_tmp_dir() ;
+ $status = $env->set_verbose() ;
+ $db_env_ptr = $env->DB_ENV() ;
+
+ $BerkeleyDB::Error
+ $BerkeleyDB::db_version
+
+ # DBM Filters
+ $old_filter = $db->filter_store_key ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+ # deprecated, but supported
+ $txn_mgr = $env->TxnMgr();
+ $status = $txn_mgr->txn_checkpoint()
+ $hash_ref = $txn_mgr->txn_stat()
+ $txn = $txn_mgr->txn_begin() ;
+
+=head1 DESCRIPTION
+
+B<NOTE: This document is still under construction. Expect it to be
+incomplete in places.>
+
+This Perl module provides an interface to most of the functionality
+available in Berkeley DB versions 2, 3 and 4. In general it is safe to assume
+that the interface provided here to be identical to the Berkeley DB
+interface. The main changes have been to make the Berkeley DB API work
+in a Perl way. Note that if you are using Berkeley DB 2.x, the new
+features available in Berkeley DB 3.x or DB 4.x are not available via
+this module.
+
+The reader is expected to be familiar with the Berkeley DB
+documentation. Where the interface provided here is identical to the
+Berkeley DB library and the... TODO
+
+The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are
+particularly relevant.
+
+The interface to Berkeley DB is implemented with a number of Perl
+classes.
+
+=head1 The BerkeleyDB::Env Class
+
+The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB
+function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and
+B<DBENV-E<gt>open> in Berkeley DB 3.x/4.x. Its purpose is to initialise a
+number of sub-systems that can then be used in a consistent way in all
+the databases you make use of in the environment.
+
+If you don't intend using transactions, locking or logging, then you
+shouldn't need to make use of B<BerkeleyDB::Env>.
+
+Note that an environment consists of a number of files that Berkeley DB
+manages behind the scenes for you. When you first use an environment, it
+needs to be explicitly created. This is done by including C<DB_CREATE>
+with the C<Flags> parameter, described below.
+
+=head2 Synopsis
+
+ $env = new BerkeleyDB::Env
+ [ -Home => $path, ]
+ [ -Server => $name, ]
+ [ -CacheSize => $number, ]
+ [ -Config => { name => value, name => value }, ]
+ [ -ErrFile => filename, ]
+ [ -MsgFile => filename, ]
+ [ -ErrPrefix => "string", ]
+ [ -Flags => number, ]
+ [ -SetFlags => bitmask, ]
+ [ -LockDetect => number, ]
+ [ -TxMax => number, ]
+ [ -LogConfig => number, ]
+ [ -MaxLockers => number, ]
+ [ -MaxLocks => number, ]
+ [ -MaxObjects => number, ]
+ [ -SharedMemKey => number, ]
+ [ -Verbose => boolean, ]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ]
+
+All the parameters to the BerkeleyDB::Env constructor are optional.
+
+=over 5
+
+=item -Home
+
+If present, this parameter should point to an existing directory. Any
+files that I<aren't> specified with an absolute path in the sub-systems
+that are initialised by the BerkeleyDB::Env class will be assumed to
+live in the B<Home> directory.
+
+For example, in the code fragment below the database "fred.db" will be
+opened in the directory "/home/databases" because it was specified as a
+relative path, but "joe.db" will be opened in "/other" because it was
+part of an absolute path.
+
+ $env = new BerkeleyDB::Env
+ -Home => "/home/databases"
+ ...
+
+ $db1 = new BerkeleyDB::Hash
+ -Filename => "fred.db",
+ -Env => $env
+ ...
+
+ $db2 = new BerkeleyDB::Hash
+ -Filename => "/other/joe.db",
+ -Env => $env
+ ...
+
+=item -Server
+
+If present, this parameter should be the hostname of a server that is running
+the Berkeley DB RPC server. All databases will be accessed via the RPC server.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Cachesize
+
+If present, this parameter sets the size of the environments shared memory
+buffer pool.
+
+=item -TxMax
+
+If present, this parameter sets the number of simultaneous
+transactions that are allowed. Default 100. This default is
+definitely too low for programs using the MVCC capabilities.
+
+=item -LogConfig
+
+If present, this parameter is used to configure log options.
+
+=item -MaxLockers
+
+If present, this parameter is used to configure the maximum number of
+processes doing locking on the database. Default 1000.
+
+=item -MaxLocks
+
+If present, this parameter is used to configure the maximum number of
+locks on the database. Default 1000. This is often lower than required.
+
+=item -MaxObjects
+
+If present, this parameter is used to configure the maximum number of
+locked objects. Default 1000. This is often lower than required.
+
+=item -SharedMemKey
+
+If present, this parameter sets the base segment ID for the shared memory
+region used by Berkeley DB.
+
+This option requires Berkeley DB 3.1 or better.
+
+Use C<$env-E<gt>get_shm_key($id)> to find out the base segment ID used
+once the environment is open.
+
+=item -ThreadCount
+
+If present, this parameter declares the approximate number of threads that
+will be used in the database environment. This parameter is only necessary
+when the $env->failchk method will be used. It does not actually set the
+maximum number of threads but rather is used to determine memory sizing.
+
+This option requires Berkeley DB 4.4 or better. It is only supported on
+Unix/Linux.
+
+=item -Config
+
+This is a variation on the C<-Home> parameter, but it allows finer
+control of where specific types of files will be stored.
+
+The parameter expects a reference to a hash. Valid keys are:
+B<DB_DATA_DIR>, B<DB_LOG_DIR> and B<DB_TMP_DIR>
+
+The code below shows an example of how it can be used.
+
+ $env = new BerkeleyDB::Env
+ -Config => { DB_DATA_DIR => "/home/databases",
+ DB_LOG_DIR => "/home/logs",
+ DB_TMP_DIR => "/home/tmp"
+ }
+ ...
+
+=item -ErrFile
+
+Expects a filename or filenhandle. Any errors generated internally by
+Berkeley DB will be logged to this file. A useful debug setting is to
+open environments with either
+
+ -ErrFile => *STDOUT
+
+or
+
+ -ErrFile => *STDERR
+
+=item -ErrPrefix
+
+Allows a prefix to be added to the error messages before they are sent
+to B<-ErrFile>.
+
+=item -Flags
+
+The B<Flags> parameter specifies both which sub-systems to initialise,
+as well as a number of environment-wide options.
+See the Berkeley DB documentation for more details of these options.
+
+Any of the following can be specified by OR'ing them:
+
+B<DB_CREATE>
+
+If any of the files specified do not already exist, create them.
+
+B<DB_INIT_CDB>
+
+Initialise the Concurrent Access Methods
+
+B<DB_INIT_LOCK>
+
+Initialise the Locking sub-system.
+
+B<DB_INIT_LOG>
+
+Initialise the Logging sub-system.
+
+B<DB_INIT_MPOOL>
+
+Initialize the shared memory buffer pool subsystem. This subsystem should be used whenever an application is using any Berkeley DB access method.
+
+B<DB_INIT_TXN>
+
+Initialize the transaction subsystem. This subsystem should be used when recovery and atomicity of multiple operations are important. The DB_INIT_TXN flag implies the DB_INIT_LOG flag.
+
+
+B<DB_MPOOL_PRIVATE>
+
+Create a private memory pool; see memp_open. Ignored unless DB_INIT_MPOOL is also specified.
+
+
+B<DB_INIT_MPOOL> is also specified.
+
+
+B<DB_NOMMAP>
+
+Do not map this database into process memory.
+
+
+B<DB_RECOVER>
+
+Run normal recovery on this environment before opening it for normal use. If this flag is set, the DB_CREATE flag must also be set since the regions will be removed and recreated.
+
+The db_appinit function returns successfully if DB_RECOVER is specified and no log files exist, so it is necessary to ensure all necessary log files are present before running recovery.
+
+
+B<DB_PRIVATE>
+
+B<DB_RECOVER_FATAL>
+
+Run catastrophic recovery on this environment before opening it for normal use. If this flag is set, the DB_CREATE flag must also be set since the regions will be removed and recreated.
+
+The db_appinit function returns successfully if DB_RECOVER_FATAL is specified and no log files exist, so it is necessary to ensure all necessary log files are present before running recovery.
+
+B<DB_THREAD>
+
+Ensure that handles returned by the Berkeley DB subsystems are useable by multiple threads within a single process, i.e., that the system is free-threaded.
+
+B<DB_TXN_NOSYNC>
+
+On transaction commit, do not synchronously flush the log; see txn_open. Ignored unless DB_INIT_TXN is also specified.
+
+B<DB_USE_ENVIRON>
+
+The Berkeley DB process' environment may be permitted to specify information to be used when naming files; see Berkeley DB File Naming. As permitting users to specify which files are used can create security problems, environment information will be used in file naming for all users only if the DB_USE_ENVIRON flag is set.
+
+B<DB_USE_ENVIRON_ROOT>
+
+The Berkeley DB process' environment may be permitted to specify information to be used when naming files; see Berkeley DB File Naming. As permitting users to specify which files are used can create security problems, if the DB_USE_ENVIRON_ROOT flag is set, environment information will be used for file naming only for users with a user-ID matching that of the superuser (specifically, users for whom the getuid(2) system call returns the user-ID 0).
+
+=item -SetFlags
+
+Calls ENV->set_flags with the supplied bitmask. Use this when you need to make
+use of DB_ENV->set_flags before DB_ENV->open is called.
+
+Only valid when Berkeley DB 3.x or better is used.
+
+=item -LockDetect
+
+Specifies what to do when a lock conflict occurs. The value should be one of
+
+B<DB_LOCK_DEFAULT>
+
+Use the default policy as specified by db_deadlock.
+
+B<DB_LOCK_OLDEST>
+
+Abort the oldest transaction.
+
+B<DB_LOCK_RANDOM>
+
+Abort a random transaction involved in the deadlock.
+
+B<DB_LOCK_YOUNGEST>
+
+Abort the youngest transaction.
+
+
+=item -Verbose
+
+Add extra debugging information to the messages sent to B<-ErrFile>.
+
+=back
+
+=head2 Methods
+
+The environment class has the following methods:
+
+=over 5
+
+=item $env->errPrefix("string") ;
+
+This method is identical to the B<-ErrPrefix> flag. It allows the
+error prefix string to be changed dynamically.
+
+=item $env->set_flags(bitmask, 1|0);
+
+=item $txn = $env->TxnMgr()
+
+Constructor for creating a B<TxnMgr> object.
+See L<"TRANSACTIONS"> for more details of using transactions.
+
+This method is deprecated. Access the transaction methods using the B<txn_>
+methods below from the environment object directly.
+
+=item $env->txn_begin()
+
+TODO
+
+=item $env->txn_stat()
+
+TODO
+
+=item $env->txn_checkpoint()
+
+TODO
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+
+=item $env->DB_ENV()
+
+Returns a pointer to the underlying DB_ENV data structure that Berkeley
+DB uses.
+
+=item $env->get_shm_key($id)
+
+Writes the base segment ID for the shared memory region used by the
+Berkeley DB environment into C<$id>. Returns 0 on success.
+
+This option requires Berkeley DB 4.2 or better.
+
+Use the C<-SharedMemKey> option when opening the environemt to set the
+base segment ID.
+
+=item $env->set_isalive()
+
+Set the callback that determines if the thread of control, identified by
+the pid and tid arguments, is still running. This method should only be
+used in combination with $env->failchk.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->failchk($flags)
+
+The $env->failchk method checks for threads of control (either a true
+thread or a process) that have exited while manipulating Berkeley DB
+library data structures, while holding a logical database lock, or with an
+unresolved transaction (that is, a transaction that was never aborted or
+committed).
+
+If $env->failchk determines a thread of control exited while holding
+database read locks, it will release those locks. If $env->failchk
+determines a thread of control exited with an unresolved transaction, the
+transaction will be aborted.
+
+Applications calling the $env->failchk method must have already called the
+$env->set_isalive method, on the same DB environement, and must have
+configured their database environment using the -ThreadCount flag. The
+ThreadCount flag cannot be used on an environment that wasn't previously
+initialized with it.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->stat_print
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->lock_stat_print
+
+Prints locking subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->mutex_stat_print
+
+Prints mutex subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.4 or better.
+
+
+=item $env->set_timeout($timeout, $flags)
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+=back
+
+=head2 Examples
+
+TODO.
+
+=head1 Global Classes
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+=head1 THE DATABASE CLASSES
+
+B<BerkeleyDB> supports the following database formats:
+
+=over 5
+
+=item B<BerkeleyDB::Hash>
+
+This database type allows arbitrary key/value pairs to be stored in data
+files. This is equivalent to the functionality provided by other
+hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
+the files created using B<BerkeleyDB::Hash> are not compatible with any
+of the other packages mentioned.
+
+A default hashing algorithm, which will be adequate for most applications,
+is built into BerkeleyDB. If you do need to use your own hashing algorithm
+it is possible to write your own in Perl and have B<BerkeleyDB> use
+it instead.
+
+=item B<BerkeleyDB::Btree>
+
+The Btree format allows arbitrary key/value pairs to be stored in a
+B+tree.
+
+As with the B<BerkeleyDB::Hash> format, it is possible to provide a
+user defined Perl routine to perform the comparison of keys. By default,
+though, the keys are stored in lexical order.
+
+=item B<BerkeleyDB::Recno>
+
+TODO.
+
+
+=item B<BerkeleyDB::Queue>
+
+TODO.
+
+=item B<BerkeleyDB::Heap>
+
+TODO.
+
+=item B<BerkeleyDB::Unknown>
+
+This isn't a database format at all. It is used when you want to open an
+existing Berkeley DB database without having to know what type is it.
+
+=back
+
+
+Each of the database formats described above is accessed via a
+corresponding B<BerkeleyDB> class. These will be described in turn in
+the next sections.
+
+=head1 BerkeleyDB::Hash
+
+Equivalent to calling B<db_open> with type B<DB_HASH> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_HASH> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Hash
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Hash',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+
+When the "tie" interface is used, reading from and writing to the database
+is achieved via the tied hash. In this case the database operates like
+a Perl associative array that happens to be stored on disk.
+
+In addition to the high-level tied hash interface, it is possible to
+make use of the underlying methods provided by Berkeley DB
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Hash> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item -Ffactor
+
+=item -Nelem
+
+See the Berkeley DB documentation for details of these options.
+
+=item -Hash
+
+Allows you to provide a user defined hash function. If not specified,
+a default hash function is used. Here is a template for a user-defined
+hash function
+
+ sub hash
+ {
+ my ($data) = shift ;
+ ...
+ # return the hash value for $data
+ return $hash ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Hash => \&hash,
+ ...
+
+See L<""> for an example.
+
+=item -DupCompare
+
+Used in conjunction with the B<DB_DUPOSRT> flag.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Property => DB_DUP|DB_DUPSORT,
+ -DupCompare => \&compare,
+ ...
+
+=back
+
+
+=head2 Methods
+
+B<BerkeleyDB::Hash> only supports the standard database methods.
+See L<COMMON DATABASE METHODS>.
+
+=head2 A Simple Tied Hash Example
+
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved from a Hash database are in an apparently random order.
+
+=head2 Another Simple Hash Example
+
+Do the same as the previous example but not using tie.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+=head2 Duplicate keys
+
+The code below is a variation on the examples above. This time the hash has
+been inverted. The key this time is colour and the value is the fruit name.
+The B<DB_DUP> flag has been specified to allow duplicates.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+here is the output:
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> banana
+ green -> apple
+
+=head2 Sorting Duplicate Keys
+
+In the previous example, when there were duplicate keys, the values are
+sorted in the order they are stored in. The code below is
+identical to the previous example except the B<DB_DUPSORT> flag is
+specified.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+
+Notice that in the output below the duplicate values are sorted.
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> apple
+ green -> banana
+
+=head2 Custom Sorting Duplicate Keys
+
+Another variation
+
+TODO
+
+=head2 Changing the hash
+
+TODO
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Btree
+
+Equivalent to calling B<db_open> with type B<DB_BTREE> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_BTREE> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+
+ $db = new BerkeleyDB::Btree
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Btree',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Btree> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item Minkey
+
+TODO
+
+=item Compare
+
+Allow you to override the default sort order used in the database. See
+L<"Changing the sort order"> for an example.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Compare => \&compare,
+ ...
+
+=item Prefix
+
+ sub prefix
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return number of bytes of $key2 which are
+ # necessary to determine that it is greater than $key1
+ return $bytes ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Prefix => \&prefix,
+ ...
+=item DupCompare
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -DupCompare => \&compare,
+ ...
+
+=item set_bt_compress
+
+Enabled compression of the btree data. The callback interface is not
+supported at present. Need Berkeley DB 4.8 or better.
+
+=back
+
+=head2 Methods
+
+B<BerkeleyDB::Btree> supports the following database methods.
+See also L<COMMON DATABASE METHODS>.
+
+All the methods below return 0 to indicate success.
+
+=over 5
+
+=item $status = $db->db_key_range($key, $less, $equal, $greater [, $flags])
+
+Given a key, C<$key>, this method returns the proportion of keys less than
+C<$key> in C<$less>, the proportion equal to C<$key> in C<$equal> and the
+proportion greater than C<$key> in C<$greater>.
+
+The proportion is returned as a double in the range 0.0 to 1.0.
+
+=back
+
+=head2 A Simple Btree Example
+
+The code below is a simple example of using a btree database.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above. The keys have been sorted using
+Berkeley DB's default sorting algorithm.
+
+ Smith
+ Wall
+ mouse
+
+
+=head2 Changing the sort order
+
+It is possible to supply your own sorting algorithm if the one that Berkeley
+DB used isn't suitable. The code below is identical to the previous example
+except for the case insensitive compare function.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
+
+You cannot change the ordering once the database has been created. Thus
+you must use the same compare function every time you access the
+database.
+
+=back
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Recno
+
+Equivalent to calling B<db_open> with type B<DB_RECNO> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_RECNO> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Recno
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Recno',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+=head2 A Recno Example
+
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
+L<Extra RECNO Methods> for a workaround).
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+
+Here is the output from the script:
+
+ The array contains 5 entries
+ popped black
+ shifted white
+ Element 1 Exists with value blue
+ The last element is green
+ The 2nd last element is yellow
+
+=head1 BerkeleyDB::Queue
+
+Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with
+type B<DB_QUEUE> in Berkeley DB 3.x or greater. This database format
+isn't available if you use Berkeley DB 2.x.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Queue
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -ExtentSize => number, ]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Queue',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+
+
+=head1 BerkeleyDB::Heap
+
+Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with
+type B<DB_HEAP> in Berkeley DB 5.2.x or greater. This database format
+isn't available if you use an older version of Berkeley DB.
+
+One form of constructor is supported:
+
+ $db = new BerkeleyDB::Heap
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Heap specific
+ [ -HeapSize => number, ]
+ [ -HeapSizeGb => number, ]
+
+=head1 BerkeleyDB::Unknown
+
+This class is used to open an existing database.
+
+Equivalent to calling B<db_open> with type B<DB_UNKNOWN> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_UNKNOWN> in
+Berkeley DB 3.x or greater.
+
+The constructor looks like this:
+
+ $db = new BerkeleyDB::Unknown
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+
+
+=head2 An example
+
+=head1 COMMON OPTIONS
+
+All database access class constructors support the common set of
+options defined below. All are optional.
+
+=over 5
+
+=item -Filename
+
+The database filename. If no filename is specified, a temporary file will
+be created and removed once the program terminates.
+
+=item -Subname
+
+Specifies the name of the sub-database to open.
+This option is only valid if you are using Berkeley DB 3.x or greater.
+
+=item -Flags
+
+Specify how the database will be opened/created. The valid flags are:
+
+B<DB_CREATE>
+
+Create any underlying files, as necessary. If the files do not already
+exist and the B<DB_CREATE> flag is not specified, the call will fail.
+
+B<DB_NOMMAP>
+
+Not supported by BerkeleyDB.
+
+B<DB_RDONLY>
+
+Opens the database in read-only mode.
+
+B<DB_THREAD>
+
+Not supported by BerkeleyDB.
+
+B<DB_TRUNCATE>
+
+If the database file already exists, remove all the data before
+opening it.
+
+=item -Mode
+
+Determines the file protection when the database is created. Defaults
+to 0666.
+
+=item -Cachesize
+
+=item -Lorder
+
+=item -Pagesize
+
+=item -Env
+
+When working under a Berkeley DB environment, this parameter
+
+Defaults to no environment.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Txn
+
+TODO.
+
+=back
+
+=head1 COMMON DATABASE METHODS
+
+All the database interfaces support the common set of methods defined
+below.
+
+All the methods below return 0 to indicate success.
+
+=head2 $env = $db->Env();
+
+Returns the environment object the database is associated with or C<undef>
+when no environment was used when opening the database.
+
+=head2 $status = $db->db_get($key, $value [, $flags])
+
+Given a key (C<$key>) this method reads the value associated with it
+from the database. If it exists, the value read from the database is
+returned in the C<$value> parameter.
+
+The B<$flags> parameter is optional. If present, it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_GET_BOTH>
+
+When the B<DB_GET_BOTH> flag is specified, B<db_get> checks for the
+existence of B<both> the C<$key> B<and> C<$value> in the database.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO
+
+=back
+
+The variant C<db_pget> allows you to query a secondary database:
+
+ $status = $sdb->db_pget($skey, $pkey, $value);
+
+using the key C<$skey> in the secondary db to lookup C<$pkey> and C<$value>
+from the primary db.
+
+=head2 $status = $db->db_exists($key [, $flags])
+
+This method checks for the existence of the given key (C<$key>), but
+does not read the value. If the key is not found, B<db_exists> will
+return B<DB_NOTFOUND>. Requires BDB 4.6 or better.
+
+=head2 $status = $db->db_put($key, $value [, $flags])
+
+Stores a key/value pair in the database.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_APPEND>
+
+This flag is only applicable when accessing a B<BerkeleyDB::Recno>
+database.
+
+TODO.
+
+
+=item B<DB_NOOVERWRITE>
+
+If this flag is specified and C<$key> already exists in the database,
+the call to B<db_put> will return B<DB_KEYEXIST>.
+
+=back
+
+=head2 $status = $db->db_del($key [, $flags])
+
+Deletes a key/value pair in the database associated with C<$key>.
+If duplicate keys are enabled in the database, B<db_del> will delete
+B<all> key/value pairs with key C<$key>.
+
+The B<$flags> parameter is optional and is currently unused.
+
+=head2 $status = $env->stat_print([$flags])
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=head2 $status = $db->db_sync()
+
+If any parts of the database are in memory, write them to the database.
+
+=head2 $cursor = $db->db_cursor([$flags])
+
+Creates a cursor object. This is used to access the contents of the
+database sequentially. See L<CURSORS> for details of the methods
+available when working with cursors.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+
+TODO
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+TODO
+
+=head2 $db->byteswapped()
+
+TODO
+
+=head2 $db->type()
+
+Returns the type of the database. The possible return code are B<DB_HASH>
+for a B<BerkeleyDB::Hash> database, B<DB_BTREE> for a B<BerkeleyDB::Btree>
+database and B<DB_RECNO> for a B<BerkeleyDB::Recno> database. This method
+is typically used when a database has been opened with
+B<BerkeleyDB::Unknown>.
+
+=head2 $bool = $env->cds_enabled();
+
+Returns true if the Berkeley DB environment C<$env> has been opened on
+CDS mode.
+
+=head2 $bool = $db->cds_enabled();
+
+Returns true if the database C<$db> has been opened on CDS mode.
+
+=head2 $lock = $db->cds_lock();
+
+Creates a CDS write lock object C<$lock>.
+
+It is a fatal error to attempt to create a cds_lock if the Berkeley DB
+environment has not been opened in CDS mode.
+
+=head2 $lock->cds_unlock();
+
+Removes a CDS lock. The destruction of the CDS lock object automatically
+calls this method.
+
+Note that if multiple CDS lock objects are created, the underlying write
+lock will not be released until all CDS lock objects are either explictly
+unlocked with this method, or the CDS lock objects have been destroyed.
+
+=head2 $ref = $db->db_stat()
+
+Returns a reference to an associative array containing information about
+the database. The keys of the associative array correspond directly to the
+names of the fields defined in the Berkeley DB documentation. For example,
+in the DB documentation, the field B<bt_version> stores the version of the
+Btree database. Assuming you called B<db_stat> on a Btree database the
+equivalent field would be accessed as follows:
+
+ $version = $ref->{'bt_version'} ;
+
+If you are using Berkeley DB 3.x or better, this method will work will
+all database formats. When DB 2.x is used, it only works with
+B<BerkeleyDB::Btree>.
+
+=head2 $status = $db->status()
+
+Returns the status of the last C<$db> method called.
+
+=head2 $status = $db->truncate($count)
+
+Truncates the datatabase and returns the number or records deleted
+in C<$count>.
+
+=head2 $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+Compacts the database C<$db>.
+
+All the parameters are optional - if only want to make use of some of them,
+use C<undef> for those you don't want. Trailing unusused parameters can be
+omitted. For example, if you only want to use the C<$c_data> parameter to
+set the C<compact_fillpercent>, write you code like this
+
+ my %hash;
+ $hash{compact_fillpercent} = 50;
+ $db->compact(undef, undef, \%hash);
+
+The parameters operate identically to the C equivalent of this method.
+The C<$c_data> needs a bit of explanation - it must be a hash reference.
+The values of the following keys can be set before calling C<compact> and
+will affect the operation of the compaction.
+
+=over 5
+
+=item * compact_fillpercent
+
+=item * compact_timeout
+
+=back
+
+The following keys, along with associated values, will be created in the
+hash reference if the C<compact> operation was successful.
+
+=over 5
+
+=item * compact_deadlock
+
+=item * compact_levels
+
+=item * compact_pages_free
+
+=item * compact_pages_examine
+
+=item * compact_pages_truncated
+
+=back
+
+You need to be running Berkeley DB 4.4 or better if you want to make use of
+C<compact>.
+
+=head2 $status = $db->associate($secondary, \&key_callback)
+
+Associate C<$db> with the secondary DB C<$secondary>
+
+New key/value pairs inserted to the database will be passed to the callback
+which must set its third argument to the secondary key to allow lookup. If
+an array reference is set multiple keys secondary keys will be associated
+with the primary database entry.
+
+Data may be retrieved fro the secondary database using C<db_pget> to also
+obtain the primary key.
+
+Secondary databased are maintained automatically.
+
+=head2 $status = $db->associate_foreign($secondary, callback, $flags)
+
+Associate a foreign key database C<$db> with the secondary DB
+C<$secondary>.
+
+The second parameter must be a reference to a sub or C<undef>.
+
+The C<$flags> parameter must be either C<DB_FOREIGN_CASCADE>,
+C<DB_FOREIGN_ABORT> or C<DB_FOREIGN_NULLIFY>.
+
+When the flags parameter is C<DB_FOREIGN_NULLIFY> the second parameter is a
+reference to a sub of the form
+
+ sub foreign_cb
+ {
+ my $key = \$_[0];
+ my $value = \$_[1];
+ my $foreignkey = \$_[2];
+ my $changed = \$_[3] ;
+
+ # for ... set $$value and set $$changed to 1
+
+ return 0;
+ }
+
+ $foreign_db->associate_foreign($secondary, \&foreign_cb, DB_FOREIGN_NULLIFY);
+
+=head1 CURSORS
+
+A cursor is used whenever you want to access the contents of a database
+in sequential order.
+A cursor object is created with the C<db_cursor>
+
+A cursor object has the following methods available:
+
+=head2 $newcursor = $cursor->c_dup($flags)
+
+Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better.
+
+The C<$flags> parameter is optional and can take the following value:
+
+=over 5
+
+=item DB_POSITION
+
+When present this flag will position the new cursor at the same place as the
+existing cursor.
+
+=back
+
+=head2 $status = $cursor->c_get($key, $value, $flags)
+
+Reads a key/value pair from the database, returning the data in C<$key>
+and C<$value>. The key/value pair actually read is controlled by the
+C<$flags> parameter, which can take B<one> of the following values:
+
+=over 5
+
+=item B<DB_FIRST>
+
+Set the cursor to point to the first key/value pair in the
+database. Return the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_LAST>
+
+Set the cursor to point to the last key/value pair in the database. Return
+the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_NEXT>
+
+If the cursor is already pointing to a key/value pair, it will be
+incremented to point to the next key/value pair and return its contents.
+
+If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>.
+
+If the cursor is already positioned at the last key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_NEXT_DUP>
+
+This flag is only valid when duplicate keys have been enabled in
+a database.
+If the cursor is already pointing to a key/value pair and the key of
+the next key/value pair is identical, the cursor will be incremented to
+point to it and their contents returned.
+
+=item B<DB_PREV>
+
+If the cursor is already pointing to a key/value pair, it will be
+decremented to point to the previous key/value pair and return its
+contents.
+
+If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>.
+
+If the cursor is already positioned at the first key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_CURRENT>
+
+If the cursor has been set to point to a key/value pair, return their
+contents.
+If the key/value pair referenced by the cursor has been deleted, B<c_get>
+will return B<DB_KEYEMPTY>.
+
+=item B<DB_SET>
+
+Set the cursor to point to the key/value pair referenced by B<$key>
+and return the value in B<$value>.
+
+=item B<DB_SET_RANGE>
+
+This flag is a variation on the B<DB_SET> flag. As well as returning
+the value, it also returns the key, via B<$key>.
+When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get>
+will be the shortest key (in length) which is greater than or equal to
+the key supplied, via B<$key>. This allows partial key searches.
+See ??? for an example of how to use this flag.
+
+=item B<DB_GET_BOTH>
+
+Another variation on B<DB_SET>. This one returns both the key and
+the value.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=item B<DB_GET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 $status = $cursor->c_put($key, $value, $flags)
+
+Stores the key/value pair in the database. The position that the data is
+stored in the database is controlled by the C<$flags> parameter, which
+must take B<one> of the following values:
+
+=over 5
+
+=item B<DB_AFTER>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately after the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+
+=item B<DB_BEFORE>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately before the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+=item B<DB_CURRENT>
+
+If the cursor has been initialised, replace the value of the key/value
+pair stored in the database with the contents of B<$value>.
+
+=item B<DB_KEYFIRST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the first entry in
+the duplicates for the particular key.
+
+=item B<DB_KEYLAST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the last entry in
+the duplicates for the particular key.
+
+=back
+
+=head2 $status = $cursor->c_del([$flags])
+
+This method deletes the key/value pair associated with the current cursor
+position. The cursor position will not be changed by this operation, so
+any subsequent cursor operation must first initialise the cursor to
+point to a valid key/value pair.
+
+If the key/value pair associated with the cursor have already been
+deleted, B<c_del> will return B<DB_KEYEMPTY>.
+
+The B<$flags> parameter is not used at present.
+
+=head2 $status = $cursor->c_count($cnt [, $flags])
+
+Stores the number of duplicates at the current cursor position in B<$cnt>.
+
+The B<$flags> parameter is not used at present. This method needs
+Berkeley DB 3.1 or better.
+
+=head2 $status = $cursor->status()
+
+Returns the status of the last cursor method as a dual type.
+
+=head2 $status = $cursor->c_pget() ;
+
+See C<db_pget>
+
+=head2 $status = $cursor->c_close()
+
+Closes the cursor B<$cursor>.
+
+=head2 Cursor Examples
+
+TODO
+
+Iterating from first to last, then in reverse.
+
+examples of each of the flags.
+
+=head1 JOIN
+
+Join support for BerkeleyDB is in progress. Watch this space.
+
+TODO
+
+=head1 TRANSACTIONS
+
+Transactions are created using the C<txn_begin> method on L<BerkeleyDB::Env>:
+
+ my $txn = $env->txn_begin;
+
+If this is a nested transaction, supply the parent transaction as an
+argument:
+
+ my $child_txn = $env->txn_begin($parent_txn);
+
+Then in order to work with the transaction, you must set it as the current
+transaction on the database handles you want to work with:
+
+ $db->Txn($txn);
+
+Or for multiple handles:
+
+ $txn->Txn(@handles);
+
+The current transaction is given by BerkeleyDB each time to the various BDB
+operations. In the C api it is required explicitly as an argument to every
+operation.
+
+To commit a transaction call the C<commit> method on it:
+
+ $txn->txn_commit;
+
+and to roll back call abort:
+
+ $txn->txn_abort
+
+After committing or aborting a child transaction you need to set the active
+transaction again using C<Txn>.
+
+
+=head1 Berkeley DB Concurrent Data Store (CDS)
+
+The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
+mechanism that is useful in scenarios where transactions are overkill.
+
+=head2 What is CDS?
+
+The Berkeley DB CDS interface is a simple lightweight locking mechanism
+that allows safe concurrent access to Berkeley DB databases. Your
+application can have multiple reader and write processes, but Berkeley DB
+will arrange it so that only one process can have a write lock against the
+database at a time, i.e. multiple processes can read from a database
+concurrently, but all write processes will be serialised.
+
+=head2 Should I use it?
+
+Whilst this simple locking model is perfectly adequate for some
+applications, it will be too restrictive for others. Before deciding on
+using CDS mode, you need to be sure that it is suitable for the expected
+behaviour of your application.
+
+The key features of this model are
+
+=over 5
+
+=item *
+
+All writes operations are serialised.
+
+=item *
+
+A write operation will block until all reads have finished.
+
+=back
+
+There are a few of the attributes of your application that you need to be
+aware of before choosing to use CDS.
+
+Firstly, if you application needs either recoverability or transaction
+support, then CDS will not be suitable.
+
+Next what is the ratio of read operation to write operations will your
+application have?
+
+If it is carrying out mostly read operations, and very few writes, then CDS
+may be appropriate.
+
+What is the expected throughput of reads/writes in your application?
+
+If you application does 90% writes and 10% reads, but on average you only
+have a transaction every 5 seconds, then the fact that all writes are
+serialised will not matter, because there will hardly ever be multiple
+writes processes blocking.
+
+In summary CDS mode may be appropriate for your application if it performs
+mostly reads and very few writes or there is a low throughput. Also, if
+you do not need to be able to roll back a series of database operations if
+an error occurs, then CDS is ok.
+
+If any of these is not the case you will need to use Berkeley DB
+transactions. That is outside the scope of this document.
+
+=head2 Locking Used
+
+Berkeley DB implements CDS mode using two kinds of lock behind the scenes -
+namely read locks and write locks. A read lock allows multiple processes to
+access the database for reading at the same time. A write lock will only
+get access to the database when there are no read or write locks active.
+The write lock will block until the process holding the lock releases it.
+
+Multiple processes with read locks can all access the database at the same
+time as long as no process has a write lock. A process with a write lock
+can only access the database if there are no other active read or write
+locks.
+
+The majority of the time the Berkeley DB CDS mode will handle all locking
+without your application having to do anything. There are a couple of
+exceptions you need to be aware of though - these will be discussed in
+L<Safely Updating Records> and L<Implicit Cursors> below.
+
+A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
+lock on the database until it is either explicitly closed or destroyed.
+This means the lock has the potential to be long lived.
+
+By default Berkeley DB cursors create a read lock, but it is possible to
+create a cursor that holds a write lock, thus
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+
+Whilst either a read or write cursor is active, it will block any other
+processes that wants to write to the database.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+For full information on CDS see the "Berkeley DB Concurrent Data Store
+applications" section in the Berkeley DB Reference Guide.
+
+
+=head2 Opening a database for CDS
+
+Here is the typical signature that is used when opening a database in CDS
+mode.
+
+ use BerkeleyDB ;
+
+ my $env = new BerkeleyDB::Env
+ -Home => "./home" ,
+ -Flags => DB_CREATE| DB_INIT_CDB | DB_INIT_MPOOL
+ or die "cannot open environment: $BerkeleyDB::Error\n";
+
+ my $db = new BerkeleyDB::Hash
+ -Filename => 'test1.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+or this, if you use the tied interface
+
+ tie %hash, "BerkeleyDB::Hash",
+ -Filename => 'test2.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+The first thing to note is that you B<MUST> always use a Berkeley DB
+environment if you want to use locking with Berkeley DB.
+
+Remember, that apart from the actual database files you explicitly create
+yourself, Berkeley DB will create a few behind the scenes to handle locking
+- they usually have names like "__db.001". It is therefore a good idea to
+use the C<-Home> option, unless you are happy for all these files to be
+written in the current directory.
+
+Next, remember to include the C<DB_CREATE> flag when opening the
+environment for the first time. A common mistake is to forget to add this
+option and then wonder why the application doesn't work.
+
+Finally, it is vital that all processes that are going to access the
+database files use the same Berkeley DB environment.
+
+
+=head2 Safely Updating a Record
+
+One of the main gotchas when using CDS is if you want to update a record in
+a database, i.e. you want to retrieve a record from a database, modify it
+in some way and put it back in the database.
+
+For example, say you are writing a web application and you want to keep a
+record of the number of times your site is accessed in a Berkeley DB
+database. So your code will have a line of code like this (assume, of
+course, that C<%hash> has been tied to a Berkeley DB database):
+
+ $hash{Counter} ++ ;
+
+That may look innocent enough, but there is a race condition lurking in
+there. If I rewrite the line of code using the low-level Berkeley DB API,
+which is what will actually be executed, the race condition may be more
+apparent:
+
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+
+Consider what happens behind the scenes when you execute the commands
+above. Firstly, the existing value for the key "Counter" is fetched from
+the database using C<db_get>. A read lock will be used for this part of the
+update. The value is then incremented, and the new value is written back
+to the database using C<db_put>. This time a write lock will be used.
+
+Here's the problem - there is nothing to stop two (or more) processes
+executing the read part at the same time. Remember multiple processes can
+hold a read lock on the database at the same time. So both will fetch the
+same value, let's say 7, from the database. Both increment the value to 8
+and attempt to write it to the database. Berkeley DB will ensure that only
+one of the processes gets a write lock, while the other will be blocked. So
+the process that happened to get the write lock will store the value 8 to
+the database and release the write lock. Now the other process will be
+unblocked, and it too will write the value 8 to the database. The result,
+in this example, is we have missed a hit in the counter.
+
+To deal with this kind of scenario, you need to make the update atomic. A
+convenience method, called C<cds_lock>, is supplied with the BerkeleyDB
+module for this purpose. Using C<cds_lock>, the counter update code can now
+be rewritten thus:
+
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ $lk->cds_unlock;
+
+or this, where scoping is used to limit the lifetime of the lock object
+
+ {
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ }
+
+Similarly, C<cds_lock> can be used with the native Berkeley DB API
+
+ my $lk = $dbh->cds_lock() ;
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+ $lk->unlock;
+
+
+The C<cds_lock> method will ensure that the current process has exclusive
+access to the database until the lock is either explicitly released, via
+the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
+
+If you are interested, all that C<cds_lock> does is open a "write" cursor.
+This has the useful side-effect of holding a write-lock on the database
+until the cursor is deleted. This is how you create a write-cursor
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+If you have instantiated multiple C<cds_lock> objects for one database
+within a single process, that process will hold a write-lock on the
+database until I<ALL> C<cds_lock> objects have been destroyed.
+
+As with all write-cursors, you should try to limit the scope of the
+C<cds_lock> to as short a time as possible. Remember the complete database
+will be locked to other process whilst the write lock is in place.
+
+=head2 Cannot write with a read cursor while a write cursor is active
+
+This issue is easier to demonstrate with an example, so consider the code
+below. The intention of the code is to increment the values of all the
+elements in a database by one.
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $cursor->c_put($key, $value+1, DB_CURRENT) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+When this code is run, it will fail on the C<c_put> line with this error
+
+ Write attempted on read-only cursor
+
+The read cursor has automatically disallowed a write operation to prevent a
+deadlock.
+
+
+So the rule is -- you B<CANNOT> carry out a write operation using a
+read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
+write-cursor is already active.
+
+The workaround for this issue is to just use C<db_put> instead of C<c_put>,
+like this
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $db->db_put($key, $value+1) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+
+=head2 Implicit Cursors
+
+All Berkeley DB cursors will hold either a read lock or a write lock on the
+database for the existence of the cursor. In order to prevent blocking of
+other processes you need to make sure that they are not long lived.
+
+There are a number of instances where the Perl interface to Berkeley DB
+will create a cursor behind the scenes without you being aware of it. Most
+of these are very short-lived and will not affect the running of your
+script, but there are a few notable exceptions.
+
+Consider this snippet of code
+
+ while (my ($k, $v) = each %hash)
+ {
+ # do something
+ }
+
+
+To implement the "each" functionality, a read cursor will be created behind
+the scenes to allow you to iterate through the tied hash, C<%hash>. While
+that cursor is still active, a read lock will obviously be held against the
+database. If your application has any other writing processes, these will
+be blocked until the read cursor is closed. That won't happen until the
+loop terminates.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+
+The locking behaviour of the C<values> or C<keys> functions, shown below,
+is subtly different.
+
+ foreach my $k (keys %hash)
+ {
+ # do something
+ }
+
+ foreach my $v (values %hash)
+ {
+ # do something
+ }
+
+
+Just as in the C<each> function, a read cursor will be created to iterate
+over the database in both of these cases. Where C<keys> and C<values>
+differ is the place where the cursor carries out the iteration through the
+database. Whilst C<each> carried out a single iteration every time it was
+invoked, the C<keys> and C<values> functions will iterate through the
+entire database in one go -- the complete database will be read into memory
+before the first iteration of the loop.
+
+Apart from the fact that a read lock will be held for the amount of time
+required to iterate through the database, the use of C<keys> and C<values>
+is B<not> recommended because it will result in the complete database being
+read into memory.
+
+
+=head2 Avoiding Deadlock with multiple databases
+
+If your CDS application uses multiple database files, and you need to write
+to more than one of them, you need to be careful you don't create a
+deadlock.
+
+For example, say you have two databases, D1 and D2, and two processes, P1
+and P2. Assume you want to write a record to each database. If P1 writes
+the records to the databases in the order D1, D2 while process P2 writes
+the records in the order D2, D1, there is the potential for a deadlock to
+occur.
+
+This scenario can be avoided by either always acquiring the write locks in
+exactly the same order in your application code, or by using the
+C<DB_CDB_ALLDB> flag when opening the environment. This flag will make a
+write-lock apply to all the databases in the environment.
+
+Add example here
+
+=head1 DBM Filters
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a DBM
+database. All of the database classes (BerkeleyDB::Hash,
+BerkeleyDB::Btree and BerkeleyDB::Recno) support DBM Filters.
+
+There are four methods associated with DBM Filters. All work
+identically, and each is used to install (or uninstall) a single DBM
+Filter. Each expects a single parameter, namely a reference to a sub.
+The only difference between them is the place that the filter is
+installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database that you need
+to share with a third-party C application. The C application assumes
+that I<all> keys and values are NULL terminated. Unfortunately when
+Perl writes to DBM databases it doesn't use NULL termination, so your
+Perl application will have to manage NULL termination itself. When you
+write to the database you will have to use something like this:
+
+ $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+ $hash{12345} = "something" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 Using BerkeleyDB with MLDBM
+
+Both BerkeleyDB::Hash and BerkeleyDB::Btree can be used with the MLDBM
+module. The code fragment below shows how to open associate MLDBM with
+BerkeleyDB::Btree. To use BerkeleyDB::Hash just replace
+BerkeleyDB::Btree with BerkeleyDB::Hash.
+
+ use strict ;
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Btree) ;
+ use Data::Dumper;
+
+ my $filename = 'testmldbm' ;
+ my %o ;
+
+ unlink $filename ;
+ tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open database '$filename: $!\n";
+
+See the MLDBM documentation for information on how to use the module
+and for details of its limitations.
+
+=head1 EXAMPLES
+
+TODO.
+
+=head1 HINTS & TIPS
+
+=head2 Sharing Databases With C Applications
+
+There is no technical reason why a Berkeley DB database cannot be
+shared by both a Perl and a C application.
+
+The vast majority of problems that are reported in this area boil down
+to the fact that C strings are NULL terminated, whilst Perl strings
+are not. See L<An Example -- the NULL termination problem.> in the DBM
+FILTERS section for a generic way to work around this problem.
+
+
+=head2 The untie Gotcha
+
+TODO
+
+=head1 COMMON QUESTIONS
+
+This section attempts to answer some of the more common questions that
+I get asked.
+
+
+=head2 Relationship with DB_File
+
+Before Berkeley DB 2.x was written there was only one Perl module that
+interfaced to Berkeley DB. That module is called B<DB_File>. Although
+B<DB_File> can be build with Berkeley DB 1.x, 2.x, 3.x or 4.x, it only
+provides an interface to the functionality available in Berkeley DB
+1.x. That means that it doesn't support transactions, locking or any of
+the other new features available in DB 2.x or better.
+
+=head2 How do I store Perl data structures with BerkeleyDB?
+
+See L<Using BerkeleyDB with MLDBM>.
+
+=head1 HISTORY
+
+See the Changes file.
+
+=head1 AVAILABILITY
+
+The most recent version of B<BerkeleyDB> can always be found
+on CPAN (see L<perlmod/CPAN> for details), in the directory
+F<modules/by-module/BerkeleyDB>.
+
+The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2004 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<BerkeleyDB> 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.
+
+Here are few words taken from the Berkeley DB FAQ (at
+F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+
+ Do I have to license DB to use it in Perl scripts?
+
+ 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 BerkeleyDB.
+See L<"AUTHOR"> for details.
+
+
+=head1 AUTHOR
+
+Paul Marquess E<lt>pmqs@cpan.orgE<gt>.
+
+
+=head1 SEE ALSO
+
+perl(1), DB_File, Berkeley DB.
+
+=cut
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB.pod.P b/lang/perl/BerkeleyDB/BerkeleyDB.pod.P
new file mode 100644
index 00000000..6e547610
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB.pod.P
@@ -0,0 +1,2357 @@
+=head1 NAME
+
+BerkeleyDB - Perl extension for Berkeley DB version 2, 3, 4 or 5
+
+=head1 SYNOPSIS
+
+ use BerkeleyDB;
+
+ $env = new BerkeleyDB::Env [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Hash', [OPTIONS] ;
+ $db = new BerkeleyDB::Hash [OPTIONS] ;
+
+ $db = tie %hash, 'BerkeleyDB::Btree', [OPTIONS] ;
+ $db = new BerkeleyDB::Btree [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Recno', [OPTIONS] ;
+ $db = new BerkeleyDB::Recno [OPTIONS] ;
+
+ $db = tie @array, 'BerkeleyDB::Queue', [OPTIONS] ;
+ $db = new BerkeleyDB::Queue [OPTIONS] ;
+
+ $db = new BerkeleyDB::Heap [OPTIONS] ;
+
+ $db = new BerkeleyDB::Unknown [OPTIONS] ;
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+ $hash{$key} = $value ;
+ $value = $hash{$key} ;
+ each %hash ;
+ keys %hash ;
+ values %hash ;
+
+ $env = $db->Env()
+ $status = $db->db_get()
+ $status = $db->db_exists() ;
+ $status = $db->db_put() ;
+ $status = $db->db_del() ;
+ $status = $db->db_sync() ;
+ $status = $db->db_close() ;
+ $status = $db->db_pget()
+ $hash_ref = $db->db_stat() ;
+ $status = $db->db_key_range();
+ $type = $db->type() ;
+ $status = $db->status() ;
+ $boolean = $db->byteswapped() ;
+ $status = $db->truncate($count) ;
+ $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+ $bool = $env->cds_enabled();
+ $bool = $db->cds_enabled();
+ $lock = $db->cds_lock();
+ $lock->cds_unlock();
+
+ ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+ ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+ $cursor = $db->db_cursor([$flags]) ;
+ $newcursor = $cursor->c_dup([$flags]);
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_put() ;
+ $status = $cursor->c_del() ;
+ $status = $cursor->c_count() ;
+ $status = $cursor->c_pget() ;
+ $status = $cursor->status() ;
+ $status = $cursor->c_close() ;
+
+ $cursor = $db->db_join() ;
+ $status = $cursor->c_get() ;
+ $status = $cursor->c_close() ;
+
+ $status = $env->txn_checkpoint()
+ $hash_ref = $env->txn_stat()
+ $status = $env->set_mutexlocks()
+ $status = $env->set_flags()
+ $status = $env->set_timeout()
+ $status = $env->lock_detect()
+ $status = $env->lsn_reset()
+
+ $txn = $env->txn_begin() ;
+ $db->Txn($txn);
+ $txn->Txn($db1, $db2,...);
+ $status = $txn->txn_prepare()
+ $status = $txn->txn_commit()
+ $status = $txn->txn_abort()
+ $status = $txn->txn_id()
+ $status = $txn->txn_discard()
+ $status = $txn->set_timeout()
+
+ $status = $env->set_lg_dir();
+ $status = $env->set_lg_bsize();
+ $status = $env->set_lg_max();
+
+ $status = $env->set_data_dir() ;
+ $status = $env->set_tmp_dir() ;
+ $status = $env->set_verbose() ;
+ $db_env_ptr = $env->DB_ENV() ;
+
+ $BerkeleyDB::Error
+ $BerkeleyDB::db_version
+
+ # DBM Filters
+ $old_filter = $db->filter_store_key ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+ # deprecated, but supported
+ $txn_mgr = $env->TxnMgr();
+ $status = $txn_mgr->txn_checkpoint()
+ $hash_ref = $txn_mgr->txn_stat()
+ $txn = $txn_mgr->txn_begin() ;
+
+=head1 DESCRIPTION
+
+B<NOTE: This document is still under construction. Expect it to be
+incomplete in places.>
+
+This Perl module provides an interface to most of the functionality
+available in Berkeley DB versions 2, 3 and 4. In general it is safe to assume
+that the interface provided here to be identical to the Berkeley DB
+interface. The main changes have been to make the Berkeley DB API work
+in a Perl way. Note that if you are using Berkeley DB 2.x, the new
+features available in Berkeley DB 3.x or DB 4.x are not available via
+this module.
+
+The reader is expected to be familiar with the Berkeley DB
+documentation. Where the interface provided here is identical to the
+Berkeley DB library and the... TODO
+
+The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are
+particularly relevant.
+
+The interface to Berkeley DB is implemented with a number of Perl
+classes.
+
+=head1 The BerkeleyDB::Env Class
+
+The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB
+function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and
+B<DBENV-E<gt>open> in Berkeley DB 3.x/4.x. Its purpose is to initialise a
+number of sub-systems that can then be used in a consistent way in all
+the databases you make use of in the environment.
+
+If you don't intend using transactions, locking or logging, then you
+shouldn't need to make use of B<BerkeleyDB::Env>.
+
+Note that an environment consists of a number of files that Berkeley DB
+manages behind the scenes for you. When you first use an environment, it
+needs to be explicitly created. This is done by including C<DB_CREATE>
+with the C<Flags> parameter, described below.
+
+=head2 Synopsis
+
+ $env = new BerkeleyDB::Env
+ [ -Home => $path, ]
+ [ -Server => $name, ]
+ [ -CacheSize => $number, ]
+ [ -Config => { name => value, name => value }, ]
+ [ -ErrFile => filename, ]
+ [ -MsgFile => filename, ]
+ [ -ErrPrefix => "string", ]
+ [ -Flags => number, ]
+ [ -SetFlags => bitmask, ]
+ [ -LockDetect => number, ]
+ [ -TxMax => number, ]
+ [ -LogConfig => number, ]
+ [ -MaxLockers => number, ]
+ [ -MaxLocks => number, ]
+ [ -MaxObjects => number, ]
+ [ -SharedMemKey => number, ]
+ [ -Verbose => boolean, ]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ]
+
+All the parameters to the BerkeleyDB::Env constructor are optional.
+
+=over 5
+
+=item -Home
+
+If present, this parameter should point to an existing directory. Any
+files that I<aren't> specified with an absolute path in the sub-systems
+that are initialised by the BerkeleyDB::Env class will be assumed to
+live in the B<Home> directory.
+
+For example, in the code fragment below the database "fred.db" will be
+opened in the directory "/home/databases" because it was specified as a
+relative path, but "joe.db" will be opened in "/other" because it was
+part of an absolute path.
+
+ $env = new BerkeleyDB::Env
+ -Home => "/home/databases"
+ ...
+
+ $db1 = new BerkeleyDB::Hash
+ -Filename => "fred.db",
+ -Env => $env
+ ...
+
+ $db2 = new BerkeleyDB::Hash
+ -Filename => "/other/joe.db",
+ -Env => $env
+ ...
+
+=item -Server
+
+If present, this parameter should be the hostname of a server that is running
+the Berkeley DB RPC server. All databases will be accessed via the RPC server.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Cachesize
+
+If present, this parameter sets the size of the environments shared memory
+buffer pool.
+
+=item -TxMax
+
+If present, this parameter sets the number of simultaneous
+transactions that are allowed. Default 100. This default is
+definitely too low for programs using the MVCC capabilities.
+
+=item -LogConfig
+
+If present, this parameter is used to configure log options.
+
+=item -MaxLockers
+
+If present, this parameter is used to configure the maximum number of
+processes doing locking on the database. Default 1000.
+
+=item -MaxLocks
+
+If present, this parameter is used to configure the maximum number of
+locks on the database. Default 1000. This is often lower than required.
+
+=item -MaxObjects
+
+If present, this parameter is used to configure the maximum number of
+locked objects. Default 1000. This is often lower than required.
+
+=item -SharedMemKey
+
+If present, this parameter sets the base segment ID for the shared memory
+region used by Berkeley DB.
+
+This option requires Berkeley DB 3.1 or better.
+
+Use C<$env-E<gt>get_shm_key($id)> to find out the base segment ID used
+once the environment is open.
+
+=item -ThreadCount
+
+If present, this parameter declares the approximate number of threads that
+will be used in the database environment. This parameter is only necessary
+when the $env->failchk method will be used. It does not actually set the
+maximum number of threads but rather is used to determine memory sizing.
+
+This option requires Berkeley DB 4.4 or better. It is only supported on
+Unix/Linux.
+
+=item -Config
+
+This is a variation on the C<-Home> parameter, but it allows finer
+control of where specific types of files will be stored.
+
+The parameter expects a reference to a hash. Valid keys are:
+B<DB_DATA_DIR>, B<DB_LOG_DIR> and B<DB_TMP_DIR>
+
+The code below shows an example of how it can be used.
+
+ $env = new BerkeleyDB::Env
+ -Config => { DB_DATA_DIR => "/home/databases",
+ DB_LOG_DIR => "/home/logs",
+ DB_TMP_DIR => "/home/tmp"
+ }
+ ...
+
+=item -ErrFile
+
+Expects a filename or filenhandle. Any errors generated internally by
+Berkeley DB will be logged to this file. A useful debug setting is to
+open environments with either
+
+ -ErrFile => *STDOUT
+
+or
+
+ -ErrFile => *STDERR
+
+=item -ErrPrefix
+
+Allows a prefix to be added to the error messages before they are sent
+to B<-ErrFile>.
+
+=item -Flags
+
+The B<Flags> parameter specifies both which sub-systems to initialise,
+as well as a number of environment-wide options.
+See the Berkeley DB documentation for more details of these options.
+
+Any of the following can be specified by OR'ing them:
+
+B<DB_CREATE>
+
+If any of the files specified do not already exist, create them.
+
+B<DB_INIT_CDB>
+
+Initialise the Concurrent Access Methods
+
+B<DB_INIT_LOCK>
+
+Initialise the Locking sub-system.
+
+B<DB_INIT_LOG>
+
+Initialise the Logging sub-system.
+
+B<DB_INIT_MPOOL>
+
+Initialize the shared memory buffer pool subsystem. This subsystem should be used whenever an application is using any Berkeley DB access method.
+
+B<DB_INIT_TXN>
+
+Initialize the transaction subsystem. This subsystem should be used when recovery and atomicity of multiple operations are important. The DB_INIT_TXN flag implies the DB_INIT_LOG flag.
+
+
+B<DB_MPOOL_PRIVATE>
+
+Create a private memory pool; see memp_open. Ignored unless DB_INIT_MPOOL is also specified.
+
+
+B<DB_INIT_MPOOL> is also specified.
+
+
+B<DB_NOMMAP>
+
+Do not map this database into process memory.
+
+
+B<DB_RECOVER>
+
+Run normal recovery on this environment before opening it for normal use. If this flag is set, the DB_CREATE flag must also be set since the regions will be removed and recreated.
+
+The db_appinit function returns successfully if DB_RECOVER is specified and no log files exist, so it is necessary to ensure all necessary log files are present before running recovery.
+
+
+B<DB_PRIVATE>
+
+B<DB_RECOVER_FATAL>
+
+Run catastrophic recovery on this environment before opening it for normal use. If this flag is set, the DB_CREATE flag must also be set since the regions will be removed and recreated.
+
+The db_appinit function returns successfully if DB_RECOVER_FATAL is specified and no log files exist, so it is necessary to ensure all necessary log files are present before running recovery.
+
+B<DB_THREAD>
+
+Ensure that handles returned by the Berkeley DB subsystems are useable by multiple threads within a single process, i.e., that the system is free-threaded.
+
+B<DB_TXN_NOSYNC>
+
+On transaction commit, do not synchronously flush the log; see txn_open. Ignored unless DB_INIT_TXN is also specified.
+
+B<DB_USE_ENVIRON>
+
+The Berkeley DB process' environment may be permitted to specify information to be used when naming files; see Berkeley DB File Naming. As permitting users to specify which files are used can create security problems, environment information will be used in file naming for all users only if the DB_USE_ENVIRON flag is set.
+
+B<DB_USE_ENVIRON_ROOT>
+
+The Berkeley DB process' environment may be permitted to specify information to be used when naming files; see Berkeley DB File Naming. As permitting users to specify which files are used can create security problems, if the DB_USE_ENVIRON_ROOT flag is set, environment information will be used for file naming only for users with a user-ID matching that of the superuser (specifically, users for whom the getuid(2) system call returns the user-ID 0).
+
+=item -SetFlags
+
+Calls ENV->set_flags with the supplied bitmask. Use this when you need to make
+use of DB_ENV->set_flags before DB_ENV->open is called.
+
+Only valid when Berkeley DB 3.x or better is used.
+
+=item -LockDetect
+
+Specifies what to do when a lock conflict occurs. The value should be one of
+
+B<DB_LOCK_DEFAULT>
+
+Use the default policy as specified by db_deadlock.
+
+B<DB_LOCK_OLDEST>
+
+Abort the oldest transaction.
+
+B<DB_LOCK_RANDOM>
+
+Abort a random transaction involved in the deadlock.
+
+B<DB_LOCK_YOUNGEST>
+
+Abort the youngest transaction.
+
+
+=item -Verbose
+
+Add extra debugging information to the messages sent to B<-ErrFile>.
+
+=back
+
+=head2 Methods
+
+The environment class has the following methods:
+
+=over 5
+
+=item $env->errPrefix("string") ;
+
+This method is identical to the B<-ErrPrefix> flag. It allows the
+error prefix string to be changed dynamically.
+
+=item $env->set_flags(bitmask, 1|0);
+
+=item $txn = $env->TxnMgr()
+
+Constructor for creating a B<TxnMgr> object.
+See L<"TRANSACTIONS"> for more details of using transactions.
+
+This method is deprecated. Access the transaction methods using the B<txn_>
+methods below from the environment object directly.
+
+=item $env->txn_begin()
+
+TODO
+
+=item $env->txn_stat()
+
+TODO
+
+=item $env->txn_checkpoint()
+
+TODO
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+
+=item $env->DB_ENV()
+
+Returns a pointer to the underlying DB_ENV data structure that Berkeley
+DB uses.
+
+=item $env->get_shm_key($id)
+
+Writes the base segment ID for the shared memory region used by the
+Berkeley DB environment into C<$id>. Returns 0 on success.
+
+This option requires Berkeley DB 4.2 or better.
+
+Use the C<-SharedMemKey> option when opening the environemt to set the
+base segment ID.
+
+=item $env->set_isalive()
+
+Set the callback that determines if the thread of control, identified by
+the pid and tid arguments, is still running. This method should only be
+used in combination with $env->failchk.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->failchk($flags)
+
+The $env->failchk method checks for threads of control (either a true
+thread or a process) that have exited while manipulating Berkeley DB
+library data structures, while holding a logical database lock, or with an
+unresolved transaction (that is, a transaction that was never aborted or
+committed).
+
+If $env->failchk determines a thread of control exited while holding
+database read locks, it will release those locks. If $env->failchk
+determines a thread of control exited with an unresolved transaction, the
+transaction will be aborted.
+
+Applications calling the $env->failchk method must have already called the
+$env->set_isalive method, on the same DB environement, and must have
+configured their database environment using the -ThreadCount flag. The
+ThreadCount flag cannot be used on an environment that wasn't previously
+initialized with it.
+
+This option requires Berkeley DB 4.4 or better.
+
+=item $env->stat_print
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->lock_stat_print
+
+Prints locking subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=item $env->mutex_stat_print
+
+Prints mutex subsystem statistics.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.4 or better.
+
+
+=item $env->set_timeout($timeout, $flags)
+
+=item $env->status()
+
+Returns the status of the last BerkeleyDB::Env method.
+
+=back
+
+=head2 Examples
+
+TODO.
+
+=head1 Global Classes
+
+ $status = BerkeleyDB::db_remove [OPTIONS]
+ $status = BerkeleyDB::db_rename [OPTIONS]
+ $status = BerkeleyDB::db_verify [OPTIONS]
+
+=head1 THE DATABASE CLASSES
+
+B<BerkeleyDB> supports the following database formats:
+
+=over 5
+
+=item B<BerkeleyDB::Hash>
+
+This database type allows arbitrary key/value pairs to be stored in data
+files. This is equivalent to the functionality provided by other
+hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
+the files created using B<BerkeleyDB::Hash> are not compatible with any
+of the other packages mentioned.
+
+A default hashing algorithm, which will be adequate for most applications,
+is built into BerkeleyDB. If you do need to use your own hashing algorithm
+it is possible to write your own in Perl and have B<BerkeleyDB> use
+it instead.
+
+=item B<BerkeleyDB::Btree>
+
+The Btree format allows arbitrary key/value pairs to be stored in a
+B+tree.
+
+As with the B<BerkeleyDB::Hash> format, it is possible to provide a
+user defined Perl routine to perform the comparison of keys. By default,
+though, the keys are stored in lexical order.
+
+=item B<BerkeleyDB::Recno>
+
+TODO.
+
+
+=item B<BerkeleyDB::Queue>
+
+TODO.
+
+=item B<BerkeleyDB::Heap>
+
+TODO.
+
+=item B<BerkeleyDB::Unknown>
+
+This isn't a database format at all. It is used when you want to open an
+existing Berkeley DB database without having to know what type is it.
+
+=back
+
+
+Each of the database formats described above is accessed via a
+corresponding B<BerkeleyDB> class. These will be described in turn in
+the next sections.
+
+=head1 BerkeleyDB::Hash
+
+Equivalent to calling B<db_open> with type B<DB_HASH> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_HASH> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Hash
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Hash',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Hash specific
+ [ -Ffactor => number,]
+ [ -Nelem => number,]
+ [ -Hash => code reference,]
+ [ -DupCompare => code reference,]
+
+
+When the "tie" interface is used, reading from and writing to the database
+is achieved via the tied hash. In this case the database operates like
+a Perl associative array that happens to be stored on disk.
+
+In addition to the high-level tied hash interface, it is possible to
+make use of the underlying methods provided by Berkeley DB
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Hash> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item -Ffactor
+
+=item -Nelem
+
+See the Berkeley DB documentation for details of these options.
+
+=item -Hash
+
+Allows you to provide a user defined hash function. If not specified,
+a default hash function is used. Here is a template for a user-defined
+hash function
+
+ sub hash
+ {
+ my ($data) = shift ;
+ ...
+ # return the hash value for $data
+ return $hash ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Hash => \&hash,
+ ...
+
+See L<""> for an example.
+
+=item -DupCompare
+
+Used in conjunction with the B<DB_DUPOSRT> flag.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Property => DB_DUP|DB_DUPSORT,
+ -DupCompare => \&compare,
+ ...
+
+=back
+
+
+=head2 Methods
+
+B<BerkeleyDB::Hash> only supports the standard database methods.
+See L<COMMON DATABASE METHODS>.
+
+=head2 A Simple Tied Hash Example
+
+## simpleHash
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved from a Hash database are in an apparently random order.
+
+=head2 Another Simple Hash Example
+
+Do the same as the previous example but not using tie.
+
+## simpleHash2
+
+=head2 Duplicate keys
+
+The code below is a variation on the examples above. This time the hash has
+been inverted. The key this time is colour and the value is the fruit name.
+The B<DB_DUP> flag has been specified to allow duplicates.
+
+##dupHash
+
+here is the output:
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> banana
+ green -> apple
+
+=head2 Sorting Duplicate Keys
+
+In the previous example, when there were duplicate keys, the values are
+sorted in the order they are stored in. The code below is
+identical to the previous example except the B<DB_DUPSORT> flag is
+specified.
+
+##dupSortHash
+
+Notice that in the output below the duplicate values are sorted.
+
+ orange -> orange
+ yellow -> banana
+ red -> apple
+ red -> tomato
+ green -> apple
+ green -> banana
+
+=head2 Custom Sorting Duplicate Keys
+
+Another variation
+
+TODO
+
+=head2 Changing the hash
+
+TODO
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Btree
+
+Equivalent to calling B<db_open> with type B<DB_BTREE> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_BTREE> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+
+ $db = new BerkeleyDB::Btree
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+and this
+
+ [$db =] tie %hash, 'BerkeleyDB::Btree',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Btree specific
+ [ -Minkey => number,]
+ [ -Compare => code reference,]
+ [ -DupCompare => code reference,]
+ [ -Prefix => code reference,]
+
+=head2 Options
+
+In addition to the standard set of options (see L<COMMON OPTIONS>)
+B<BerkeleyDB::Btree> supports these options:
+
+=over 5
+
+=item -Property
+
+Used to specify extra flags when opening a database. The following
+flags may be specified by bitwise OR'ing together one or more of the
+following values:
+
+B<DB_DUP>
+
+When creating a new database, this flag enables the storing of duplicate
+keys in the database. If B<DB_DUPSORT> is not specified as well, the
+duplicates are stored in the order they are created in the database.
+
+B<DB_DUPSORT>
+
+Enables the sorting of duplicate keys in the database. Ignored if
+B<DB_DUP> isn't also specified.
+
+=item Minkey
+
+TODO
+
+=item Compare
+
+Allow you to override the default sort order used in the database. See
+L<"Changing the sort order"> for an example.
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Compare => \&compare,
+ ...
+
+=item Prefix
+
+ sub prefix
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return number of bytes of $key2 which are
+ # necessary to determine that it is greater than $key1
+ return $bytes ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Prefix => \&prefix,
+ ...
+=item DupCompare
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -DupCompare => \&compare,
+ ...
+
+=item set_bt_compress
+
+Enabled compression of the btree data. The callback interface is not
+supported at present. Need Berkeley DB 4.8 or better.
+
+=back
+
+=head2 Methods
+
+B<BerkeleyDB::Btree> supports the following database methods.
+See also L<COMMON DATABASE METHODS>.
+
+All the methods below return 0 to indicate success.
+
+=over 5
+
+=item $status = $db->db_key_range($key, $less, $equal, $greater [, $flags])
+
+Given a key, C<$key>, this method returns the proportion of keys less than
+C<$key> in C<$less>, the proportion equal to C<$key> in C<$equal> and the
+proportion greater than C<$key> in C<$greater>.
+
+The proportion is returned as a double in the range 0.0 to 1.0.
+
+=back
+
+=head2 A Simple Btree Example
+
+The code below is a simple example of using a btree database.
+
+## btreeSimple
+
+Here is the output from the code above. The keys have been sorted using
+Berkeley DB's default sorting algorithm.
+
+ Smith
+ Wall
+ mouse
+
+
+=head2 Changing the sort order
+
+It is possible to supply your own sorting algorithm if the one that Berkeley
+DB used isn't suitable. The code below is identical to the previous example
+except for the case insensitive compare function.
+
+## btreeSortOrder
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
+
+You cannot change the ordering once the database has been created. Thus
+you must use the same compare function every time you access the
+database.
+
+=back
+
+=head2 Using db_stat
+
+TODO
+
+=head1 BerkeleyDB::Recno
+
+Equivalent to calling B<db_open> with type B<DB_RECNO> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_RECNO> in
+Berkeley DB 3.x or greater.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Recno
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Recno',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Recno specific
+ [ -Delim => byte,]
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -Source => filename,]
+
+=head2 A Recno Example
+
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
+L<Extra RECNO Methods> for a workaround).
+
+## simpleRecno
+
+Here is the output from the script:
+
+ The array contains 5 entries
+ popped black
+ shifted white
+ Element 1 Exists with value blue
+ The last element is green
+ The 2nd last element is yellow
+
+=head1 BerkeleyDB::Queue
+
+Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with
+type B<DB_QUEUE> in Berkeley DB 3.x or greater. This database format
+isn't available if you use Berkeley DB 2.x.
+
+Two forms of constructor are supported:
+
+ $db = new BerkeleyDB::Queue
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+ [ -ExtentSize => number, ]
+
+and this
+
+ [$db =] tie @arry, 'BerkeleyDB::Queue',
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Queue specific
+ [ -Len => number,]
+ [ -Pad => byte,]
+
+
+=head1 BerkeleyDB::Heap
+
+Equivalent to calling B<db_create> followed by B<DB-E<gt>open> with
+type B<DB_HEAP> in Berkeley DB 5.2.x or greater. This database format
+isn't available if you use an older version of Berkeley DB.
+
+One form of constructor is supported:
+
+ $db = new BerkeleyDB::Heap
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+ # BerkeleyDB::Heap specific
+ [ -HeapSize => number, ]
+ [ -HeapSizeGb => number, ]
+
+=head1 BerkeleyDB::Unknown
+
+This class is used to open an existing database.
+
+Equivalent to calling B<db_open> with type B<DB_UNKNOWN> in Berkeley DB 2.x and
+calling B<db_create> followed by B<DB-E<gt>open> with type B<DB_UNKNOWN> in
+Berkeley DB 3.x or greater.
+
+The constructor looks like this:
+
+ $db = new BerkeleyDB::Unknown
+ [ -Filename => "filename", ]
+ [ -Subname => "sub-database name", ]
+ [ -Flags => flags,]
+ [ -Property => flags,]
+ [ -Mode => number,]
+ [ -Cachesize => number,]
+ [ -Lorder => number,]
+ [ -Pagesize => number,]
+ [ -Env => $env,]
+ [ -Txn => $txn,]
+ [ -Encrypt => { Password => "string",
+ Flags => number }, ],
+
+
+=head2 An example
+
+=head1 COMMON OPTIONS
+
+All database access class constructors support the common set of
+options defined below. All are optional.
+
+=over 5
+
+=item -Filename
+
+The database filename. If no filename is specified, a temporary file will
+be created and removed once the program terminates.
+
+=item -Subname
+
+Specifies the name of the sub-database to open.
+This option is only valid if you are using Berkeley DB 3.x or greater.
+
+=item -Flags
+
+Specify how the database will be opened/created. The valid flags are:
+
+B<DB_CREATE>
+
+Create any underlying files, as necessary. If the files do not already
+exist and the B<DB_CREATE> flag is not specified, the call will fail.
+
+B<DB_NOMMAP>
+
+Not supported by BerkeleyDB.
+
+B<DB_RDONLY>
+
+Opens the database in read-only mode.
+
+B<DB_THREAD>
+
+Not supported by BerkeleyDB.
+
+B<DB_TRUNCATE>
+
+If the database file already exists, remove all the data before
+opening it.
+
+=item -Mode
+
+Determines the file protection when the database is created. Defaults
+to 0666.
+
+=item -Cachesize
+
+=item -Lorder
+
+=item -Pagesize
+
+=item -Env
+
+When working under a Berkeley DB environment, this parameter
+
+Defaults to no environment.
+
+=item -Encrypt
+
+If present, this parameter will enable encryption of all data before
+it is written to the database. This parameters must be given a hash
+reference. The format is shown below.
+
+ -Encrypt => { -Password => "abc", Flags => DB_ENCRYPT_AES }
+
+Valid values for the Flags are 0 or C<DB_ENCRYPT_AES>.
+
+This option requires Berkeley DB 4.1 or better.
+
+=item -Txn
+
+TODO.
+
+=back
+
+=head1 COMMON DATABASE METHODS
+
+All the database interfaces support the common set of methods defined
+below.
+
+All the methods below return 0 to indicate success.
+
+=head2 $env = $db->Env();
+
+Returns the environment object the database is associated with or C<undef>
+when no environment was used when opening the database.
+
+=head2 $status = $db->db_get($key, $value [, $flags])
+
+Given a key (C<$key>) this method reads the value associated with it
+from the database. If it exists, the value read from the database is
+returned in the C<$value> parameter.
+
+The B<$flags> parameter is optional. If present, it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_GET_BOTH>
+
+When the B<DB_GET_BOTH> flag is specified, B<db_get> checks for the
+existence of B<both> the C<$key> B<and> C<$value> in the database.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO
+
+=back
+
+The variant C<db_pget> allows you to query a secondary database:
+
+ $status = $sdb->db_pget($skey, $pkey, $value);
+
+using the key C<$skey> in the secondary db to lookup C<$pkey> and C<$value>
+from the primary db.
+
+=head2 $status = $db->db_exists($key [, $flags])
+
+This method checks for the existence of the given key (C<$key>), but
+does not read the value. If the key is not found, B<db_exists> will
+return B<DB_NOTFOUND>. Requires BDB 4.6 or better.
+
+=head2 $status = $db->db_put($key, $value [, $flags])
+
+Stores a key/value pair in the database.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_APPEND>
+
+This flag is only applicable when accessing a B<BerkeleyDB::Recno>
+database.
+
+TODO.
+
+
+=item B<DB_NOOVERWRITE>
+
+If this flag is specified and C<$key> already exists in the database,
+the call to B<db_put> will return B<DB_KEYEXIST>.
+
+=back
+
+=head2 $status = $db->db_del($key [, $flags])
+
+Deletes a key/value pair in the database associated with C<$key>.
+If duplicate keys are enabled in the database, B<db_del> will delete
+B<all> key/value pairs with key C<$key>.
+
+The B<$flags> parameter is optional and is currently unused.
+
+=head2 $status = $env->stat_print([$flags])
+
+Prints statistical information.
+
+If the C<MsgFile> option is specified the output will be sent to the
+file. Otherwise output is sent to standard output.
+
+This option requires Berkeley DB 4.3 or better.
+
+=head2 $status = $db->db_sync()
+
+If any parts of the database are in memory, write them to the database.
+
+=head2 $cursor = $db->db_cursor([$flags])
+
+Creates a cursor object. This is used to access the contents of the
+database sequentially. See L<CURSORS> for details of the methods
+available when working with cursors.
+
+The B<$flags> parameter is optional. If present it must be set to B<one>
+of the following values:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
+
+TODO
+
+=head2 ($flag, $old_offset, $old_length) = $db->partial_clear() ;
+
+TODO
+
+=head2 $db->byteswapped()
+
+TODO
+
+=head2 $db->type()
+
+Returns the type of the database. The possible return code are B<DB_HASH>
+for a B<BerkeleyDB::Hash> database, B<DB_BTREE> for a B<BerkeleyDB::Btree>
+database and B<DB_RECNO> for a B<BerkeleyDB::Recno> database. This method
+is typically used when a database has been opened with
+B<BerkeleyDB::Unknown>.
+
+=head2 $bool = $env->cds_enabled();
+
+Returns true if the Berkeley DB environment C<$env> has been opened on
+CDS mode.
+
+=head2 $bool = $db->cds_enabled();
+
+Returns true if the database C<$db> has been opened on CDS mode.
+
+=head2 $lock = $db->cds_lock();
+
+Creates a CDS write lock object C<$lock>.
+
+It is a fatal error to attempt to create a cds_lock if the Berkeley DB
+environment has not been opened in CDS mode.
+
+=head2 $lock->cds_unlock();
+
+Removes a CDS lock. The destruction of the CDS lock object automatically
+calls this method.
+
+Note that if multiple CDS lock objects are created, the underlying write
+lock will not be released until all CDS lock objects are either explictly
+unlocked with this method, or the CDS lock objects have been destroyed.
+
+=head2 $ref = $db->db_stat()
+
+Returns a reference to an associative array containing information about
+the database. The keys of the associative array correspond directly to the
+names of the fields defined in the Berkeley DB documentation. For example,
+in the DB documentation, the field B<bt_version> stores the version of the
+Btree database. Assuming you called B<db_stat> on a Btree database the
+equivalent field would be accessed as follows:
+
+ $version = $ref->{'bt_version'} ;
+
+If you are using Berkeley DB 3.x or better, this method will work will
+all database formats. When DB 2.x is used, it only works with
+B<BerkeleyDB::Btree>.
+
+=head2 $status = $db->status()
+
+Returns the status of the last C<$db> method called.
+
+=head2 $status = $db->truncate($count)
+
+Truncates the datatabase and returns the number or records deleted
+in C<$count>.
+
+=head2 $status = $db->compact($start, $stop, $c_data, $flags, $end);
+
+Compacts the database C<$db>.
+
+All the parameters are optional - if only want to make use of some of them,
+use C<undef> for those you don't want. Trailing unusused parameters can be
+omitted. For example, if you only want to use the C<$c_data> parameter to
+set the C<compact_fillpercent>, write you code like this
+
+ my %hash;
+ $hash{compact_fillpercent} = 50;
+ $db->compact(undef, undef, \%hash);
+
+The parameters operate identically to the C equivalent of this method.
+The C<$c_data> needs a bit of explanation - it must be a hash reference.
+The values of the following keys can be set before calling C<compact> and
+will affect the operation of the compaction.
+
+=over 5
+
+=item * compact_fillpercent
+
+=item * compact_timeout
+
+=back
+
+The following keys, along with associated values, will be created in the
+hash reference if the C<compact> operation was successful.
+
+=over 5
+
+=item * compact_deadlock
+
+=item * compact_levels
+
+=item * compact_pages_free
+
+=item * compact_pages_examine
+
+=item * compact_pages_truncated
+
+=back
+
+You need to be running Berkeley DB 4.4 or better if you want to make use of
+C<compact>.
+
+=head2 $status = $db->associate($secondary, \&key_callback)
+
+Associate C<$db> with the secondary DB C<$secondary>
+
+New key/value pairs inserted to the database will be passed to the callback
+which must set its third argument to the secondary key to allow lookup. If
+an array reference is set multiple keys secondary keys will be associated
+with the primary database entry.
+
+Data may be retrieved fro the secondary database using C<db_pget> to also
+obtain the primary key.
+
+Secondary databased are maintained automatically.
+
+=head2 $status = $db->associate_foreign($secondary, callback, $flags)
+
+Associate a foreign key database C<$db> with the secondary DB
+C<$secondary>.
+
+The second parameter must be a reference to a sub or C<undef>.
+
+The C<$flags> parameter must be either C<DB_FOREIGN_CASCADE>,
+C<DB_FOREIGN_ABORT> or C<DB_FOREIGN_NULLIFY>.
+
+When the flags parameter is C<DB_FOREIGN_NULLIFY> the second parameter is a
+reference to a sub of the form
+
+ sub foreign_cb
+ {
+ my $key = \$_[0];
+ my $value = \$_[1];
+ my $foreignkey = \$_[2];
+ my $changed = \$_[3] ;
+
+ # for ... set $$value and set $$changed to 1
+
+ return 0;
+ }
+
+ $foreign_db->associate_foreign($secondary, \&foreign_cb, DB_FOREIGN_NULLIFY);
+
+=head1 CURSORS
+
+A cursor is used whenever you want to access the contents of a database
+in sequential order.
+A cursor object is created with the C<db_cursor>
+
+A cursor object has the following methods available:
+
+=head2 $newcursor = $cursor->c_dup($flags)
+
+Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better.
+
+The C<$flags> parameter is optional and can take the following value:
+
+=over 5
+
+=item DB_POSITION
+
+When present this flag will position the new cursor at the same place as the
+existing cursor.
+
+=back
+
+=head2 $status = $cursor->c_get($key, $value, $flags)
+
+Reads a key/value pair from the database, returning the data in C<$key>
+and C<$value>. The key/value pair actually read is controlled by the
+C<$flags> parameter, which can take B<one> of the following values:
+
+=over 5
+
+=item B<DB_FIRST>
+
+Set the cursor to point to the first key/value pair in the
+database. Return the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_LAST>
+
+Set the cursor to point to the last key/value pair in the database. Return
+the key/value pair in C<$key> and C<$value>.
+
+=item B<DB_NEXT>
+
+If the cursor is already pointing to a key/value pair, it will be
+incremented to point to the next key/value pair and return its contents.
+
+If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>.
+
+If the cursor is already positioned at the last key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_NEXT_DUP>
+
+This flag is only valid when duplicate keys have been enabled in
+a database.
+If the cursor is already pointing to a key/value pair and the key of
+the next key/value pair is identical, the cursor will be incremented to
+point to it and their contents returned.
+
+=item B<DB_PREV>
+
+If the cursor is already pointing to a key/value pair, it will be
+decremented to point to the previous key/value pair and return its
+contents.
+
+If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>.
+
+If the cursor is already positioned at the first key/value pair, B<c_get>
+will return B<DB_NOTFOUND>.
+
+=item B<DB_CURRENT>
+
+If the cursor has been set to point to a key/value pair, return their
+contents.
+If the key/value pair referenced by the cursor has been deleted, B<c_get>
+will return B<DB_KEYEMPTY>.
+
+=item B<DB_SET>
+
+Set the cursor to point to the key/value pair referenced by B<$key>
+and return the value in B<$value>.
+
+=item B<DB_SET_RANGE>
+
+This flag is a variation on the B<DB_SET> flag. As well as returning
+the value, it also returns the key, via B<$key>.
+When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get>
+will be the shortest key (in length) which is greater than or equal to
+the key supplied, via B<$key>. This allows partial key searches.
+See ??? for an example of how to use this flag.
+
+=item B<DB_GET_BOTH>
+
+Another variation on B<DB_SET>. This one returns both the key and
+the value.
+
+=item B<DB_SET_RECNO>
+
+TODO.
+
+=item B<DB_GET_RECNO>
+
+TODO.
+
+=back
+
+In addition, the following value may be set by bitwise OR'ing it into
+the B<$flags> parameter:
+
+=over 5
+
+=item B<DB_RMW>
+
+TODO.
+
+=back
+
+=head2 $status = $cursor->c_put($key, $value, $flags)
+
+Stores the key/value pair in the database. The position that the data is
+stored in the database is controlled by the C<$flags> parameter, which
+must take B<one> of the following values:
+
+=over 5
+
+=item B<DB_AFTER>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately after the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+
+=item B<DB_BEFORE>
+
+When used with a Btree or Hash database, a duplicate of the key referenced
+by the current cursor position will be created and the contents of
+B<$value> will be associated with it - B<$key> is ignored.
+The new key/value pair will be stored immediately before the current
+cursor position.
+Obviously the database has to have been opened with B<DB_DUP>.
+
+When used with a Recno ... TODO
+
+=item B<DB_CURRENT>
+
+If the cursor has been initialised, replace the value of the key/value
+pair stored in the database with the contents of B<$value>.
+
+=item B<DB_KEYFIRST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the first entry in
+the duplicates for the particular key.
+
+=item B<DB_KEYLAST>
+
+Only valid with a Btree or Hash database. This flag is only really
+used when duplicates are enabled in the database and sorted duplicates
+haven't been specified.
+In this case the key/value pair will be inserted as the last entry in
+the duplicates for the particular key.
+
+=back
+
+=head2 $status = $cursor->c_del([$flags])
+
+This method deletes the key/value pair associated with the current cursor
+position. The cursor position will not be changed by this operation, so
+any subsequent cursor operation must first initialise the cursor to
+point to a valid key/value pair.
+
+If the key/value pair associated with the cursor have already been
+deleted, B<c_del> will return B<DB_KEYEMPTY>.
+
+The B<$flags> parameter is not used at present.
+
+=head2 $status = $cursor->c_count($cnt [, $flags])
+
+Stores the number of duplicates at the current cursor position in B<$cnt>.
+
+The B<$flags> parameter is not used at present. This method needs
+Berkeley DB 3.1 or better.
+
+=head2 $status = $cursor->status()
+
+Returns the status of the last cursor method as a dual type.
+
+=head2 $status = $cursor->c_pget() ;
+
+See C<db_pget>
+
+=head2 $status = $cursor->c_close()
+
+Closes the cursor B<$cursor>.
+
+=head2 Cursor Examples
+
+TODO
+
+Iterating from first to last, then in reverse.
+
+examples of each of the flags.
+
+=head1 JOIN
+
+Join support for BerkeleyDB is in progress. Watch this space.
+
+TODO
+
+=head1 TRANSACTIONS
+
+Transactions are created using the C<txn_begin> method on L<BerkeleyDB::Env>:
+
+ my $txn = $env->txn_begin;
+
+If this is a nested transaction, supply the parent transaction as an
+argument:
+
+ my $child_txn = $env->txn_begin($parent_txn);
+
+Then in order to work with the transaction, you must set it as the current
+transaction on the database handles you want to work with:
+
+ $db->Txn($txn);
+
+Or for multiple handles:
+
+ $txn->Txn(@handles);
+
+The current transaction is given by BerkeleyDB each time to the various BDB
+operations. In the C api it is required explicitly as an argument to every
+operation.
+
+To commit a transaction call the C<commit> method on it:
+
+ $txn->txn_commit;
+
+and to roll back call abort:
+
+ $txn->txn_abort
+
+After committing or aborting a child transaction you need to set the active
+transaction again using C<Txn>.
+
+
+=head1 Berkeley DB Concurrent Data Store (CDS)
+
+The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
+mechanism that is useful in scenarios where transactions are overkill.
+
+=head2 What is CDS?
+
+The Berkeley DB CDS interface is a simple lightweight locking mechanism
+that allows safe concurrent access to Berkeley DB databases. Your
+application can have multiple reader and write processes, but Berkeley DB
+will arrange it so that only one process can have a write lock against the
+database at a time, i.e. multiple processes can read from a database
+concurrently, but all write processes will be serialised.
+
+=head2 Should I use it?
+
+Whilst this simple locking model is perfectly adequate for some
+applications, it will be too restrictive for others. Before deciding on
+using CDS mode, you need to be sure that it is suitable for the expected
+behaviour of your application.
+
+The key features of this model are
+
+=over 5
+
+=item *
+
+All writes operations are serialised.
+
+=item *
+
+A write operation will block until all reads have finished.
+
+=back
+
+There are a few of the attributes of your application that you need to be
+aware of before choosing to use CDS.
+
+Firstly, if you application needs either recoverability or transaction
+support, then CDS will not be suitable.
+
+Next what is the ratio of read operation to write operations will your
+application have?
+
+If it is carrying out mostly read operations, and very few writes, then CDS
+may be appropriate.
+
+What is the expected throughput of reads/writes in your application?
+
+If you application does 90% writes and 10% reads, but on average you only
+have a transaction every 5 seconds, then the fact that all writes are
+serialised will not matter, because there will hardly ever be multiple
+writes processes blocking.
+
+In summary CDS mode may be appropriate for your application if it performs
+mostly reads and very few writes or there is a low throughput. Also, if
+you do not need to be able to roll back a series of database operations if
+an error occurs, then CDS is ok.
+
+If any of these is not the case you will need to use Berkeley DB
+transactions. That is outside the scope of this document.
+
+=head2 Locking Used
+
+Berkeley DB implements CDS mode using two kinds of lock behind the scenes -
+namely read locks and write locks. A read lock allows multiple processes to
+access the database for reading at the same time. A write lock will only
+get access to the database when there are no read or write locks active.
+The write lock will block until the process holding the lock releases it.
+
+Multiple processes with read locks can all access the database at the same
+time as long as no process has a write lock. A process with a write lock
+can only access the database if there are no other active read or write
+locks.
+
+The majority of the time the Berkeley DB CDS mode will handle all locking
+without your application having to do anything. There are a couple of
+exceptions you need to be aware of though - these will be discussed in
+L<Safely Updating Records> and L<Implicit Cursors> below.
+
+A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
+lock on the database until it is either explicitly closed or destroyed.
+This means the lock has the potential to be long lived.
+
+By default Berkeley DB cursors create a read lock, but it is possible to
+create a cursor that holds a write lock, thus
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+
+Whilst either a read or write cursor is active, it will block any other
+processes that wants to write to the database.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+For full information on CDS see the "Berkeley DB Concurrent Data Store
+applications" section in the Berkeley DB Reference Guide.
+
+
+=head2 Opening a database for CDS
+
+Here is the typical signature that is used when opening a database in CDS
+mode.
+
+ use BerkeleyDB ;
+
+ my $env = new BerkeleyDB::Env
+ -Home => "./home" ,
+ -Flags => DB_CREATE| DB_INIT_CDB | DB_INIT_MPOOL
+ or die "cannot open environment: $BerkeleyDB::Error\n";
+
+ my $db = new BerkeleyDB::Hash
+ -Filename => 'test1.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+or this, if you use the tied interface
+
+ tie %hash, "BerkeleyDB::Hash",
+ -Filename => 'test2.db',
+ -Flags => DB_CREATE,
+ -Env => $env
+ or die "cannot open database: $BerkeleyDB::Error\n";
+
+The first thing to note is that you B<MUST> always use a Berkeley DB
+environment if you want to use locking with Berkeley DB.
+
+Remember, that apart from the actual database files you explicitly create
+yourself, Berkeley DB will create a few behind the scenes to handle locking
+- they usually have names like "__db.001". It is therefore a good idea to
+use the C<-Home> option, unless you are happy for all these files to be
+written in the current directory.
+
+Next, remember to include the C<DB_CREATE> flag when opening the
+environment for the first time. A common mistake is to forget to add this
+option and then wonder why the application doesn't work.
+
+Finally, it is vital that all processes that are going to access the
+database files use the same Berkeley DB environment.
+
+
+=head2 Safely Updating a Record
+
+One of the main gotchas when using CDS is if you want to update a record in
+a database, i.e. you want to retrieve a record from a database, modify it
+in some way and put it back in the database.
+
+For example, say you are writing a web application and you want to keep a
+record of the number of times your site is accessed in a Berkeley DB
+database. So your code will have a line of code like this (assume, of
+course, that C<%hash> has been tied to a Berkeley DB database):
+
+ $hash{Counter} ++ ;
+
+That may look innocent enough, but there is a race condition lurking in
+there. If I rewrite the line of code using the low-level Berkeley DB API,
+which is what will actually be executed, the race condition may be more
+apparent:
+
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+
+Consider what happens behind the scenes when you execute the commands
+above. Firstly, the existing value for the key "Counter" is fetched from
+the database using C<db_get>. A read lock will be used for this part of the
+update. The value is then incremented, and the new value is written back
+to the database using C<db_put>. This time a write lock will be used.
+
+Here's the problem - there is nothing to stop two (or more) processes
+executing the read part at the same time. Remember multiple processes can
+hold a read lock on the database at the same time. So both will fetch the
+same value, let's say 7, from the database. Both increment the value to 8
+and attempt to write it to the database. Berkeley DB will ensure that only
+one of the processes gets a write lock, while the other will be blocked. So
+the process that happened to get the write lock will store the value 8 to
+the database and release the write lock. Now the other process will be
+unblocked, and it too will write the value 8 to the database. The result,
+in this example, is we have missed a hit in the counter.
+
+To deal with this kind of scenario, you need to make the update atomic. A
+convenience method, called C<cds_lock>, is supplied with the BerkeleyDB
+module for this purpose. Using C<cds_lock>, the counter update code can now
+be rewritten thus:
+
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ $lk->cds_unlock;
+
+or this, where scoping is used to limit the lifetime of the lock object
+
+ {
+ my $lk = $dbh->cds_lock() ;
+ $hash{Counter} ++ ;
+ }
+
+Similarly, C<cds_lock> can be used with the native Berkeley DB API
+
+ my $lk = $dbh->cds_lock() ;
+ $db->db_get("Counter", $value);
+ ++ $value ;
+ $db->db_put("Counter", $value);
+ $lk->unlock;
+
+
+The C<cds_lock> method will ensure that the current process has exclusive
+access to the database until the lock is either explicitly released, via
+the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
+
+If you are interested, all that C<cds_lock> does is open a "write" cursor.
+This has the useful side-effect of holding a write-lock on the database
+until the cursor is deleted. This is how you create a write-cursor
+
+ $cursor = $db->db_cursor(DB_WRITECURSOR);
+
+If you have instantiated multiple C<cds_lock> objects for one database
+within a single process, that process will hold a write-lock on the
+database until I<ALL> C<cds_lock> objects have been destroyed.
+
+As with all write-cursors, you should try to limit the scope of the
+C<cds_lock> to as short a time as possible. Remember the complete database
+will be locked to other process whilst the write lock is in place.
+
+=head2 Cannot write with a read cursor while a write cursor is active
+
+This issue is easier to demonstrate with an example, so consider the code
+below. The intention of the code is to increment the values of all the
+elements in a database by one.
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $cursor->c_put($key, $value+1, DB_CURRENT) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+When this code is run, it will fail on the C<c_put> line with this error
+
+ Write attempted on read-only cursor
+
+The read cursor has automatically disallowed a write operation to prevent a
+deadlock.
+
+
+So the rule is -- you B<CANNOT> carry out a write operation using a
+read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
+write-cursor is already active.
+
+The workaround for this issue is to just use C<db_put> instead of C<c_put>,
+like this
+
+ # Assume $db is a database opened in a CDS environment.
+
+ # Create a write-lock
+ my $lock = $db->db_cursor(DB_WRITECURSOR);
+ # or
+ # my $lock = $db->cds_lock();
+
+
+ my $cursor = $db->db_cursor();
+
+ # Now loop through the database, and increment
+ # each value using c_put.
+ while ($cursor->c_get($key, $value, DB_NEXT) == 0)
+ {
+ $db->db_put($key, $value+1) == 0
+ or die "$BerkeleyDB::Error\n";
+ }
+
+
+
+=head2 Implicit Cursors
+
+All Berkeley DB cursors will hold either a read lock or a write lock on the
+database for the existence of the cursor. In order to prevent blocking of
+other processes you need to make sure that they are not long lived.
+
+There are a number of instances where the Perl interface to Berkeley DB
+will create a cursor behind the scenes without you being aware of it. Most
+of these are very short-lived and will not affect the running of your
+script, but there are a few notable exceptions.
+
+Consider this snippet of code
+
+ while (my ($k, $v) = each %hash)
+ {
+ # do something
+ }
+
+
+To implement the "each" functionality, a read cursor will be created behind
+the scenes to allow you to iterate through the tied hash, C<%hash>. While
+that cursor is still active, a read lock will obviously be held against the
+database. If your application has any other writing processes, these will
+be blocked until the read cursor is closed. That won't happen until the
+loop terminates.
+
+To avoid blocking problems, only keep cursors open as long as they are
+needed. The same is true when you use the C<cursor> method or the
+C<cds_lock> method.
+
+
+The locking behaviour of the C<values> or C<keys> functions, shown below,
+is subtly different.
+
+ foreach my $k (keys %hash)
+ {
+ # do something
+ }
+
+ foreach my $v (values %hash)
+ {
+ # do something
+ }
+
+
+Just as in the C<each> function, a read cursor will be created to iterate
+over the database in both of these cases. Where C<keys> and C<values>
+differ is the place where the cursor carries out the iteration through the
+database. Whilst C<each> carried out a single iteration every time it was
+invoked, the C<keys> and C<values> functions will iterate through the
+entire database in one go -- the complete database will be read into memory
+before the first iteration of the loop.
+
+Apart from the fact that a read lock will be held for the amount of time
+required to iterate through the database, the use of C<keys> and C<values>
+is B<not> recommended because it will result in the complete database being
+read into memory.
+
+
+=head2 Avoiding Deadlock with multiple databases
+
+If your CDS application uses multiple database files, and you need to write
+to more than one of them, you need to be careful you don't create a
+deadlock.
+
+For example, say you have two databases, D1 and D2, and two processes, P1
+and P2. Assume you want to write a record to each database. If P1 writes
+the records to the databases in the order D1, D2 while process P2 writes
+the records in the order D2, D1, there is the potential for a deadlock to
+occur.
+
+This scenario can be avoided by either always acquiring the write locks in
+exactly the same order in your application code, or by using the
+C<DB_CDB_ALLDB> flag when opening the environment. This flag will make a
+write-lock apply to all the databases in the environment.
+
+Add example here
+
+=head1 DBM Filters
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a DBM
+database. All of the database classes (BerkeleyDB::Hash,
+BerkeleyDB::Btree and BerkeleyDB::Recno) support DBM Filters.
+
+There are four methods associated with DBM Filters. All work
+identically, and each is used to install (or uninstall) a single DBM
+Filter. Each expects a single parameter, namely a reference to a sub.
+The only difference between them is the place that the filter is
+installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database that you need
+to share with a third-party C application. The C application assumes
+that I<all> keys and values are NULL terminated. Unfortunately when
+Perl writes to DBM databases it doesn't use NULL termination, so your
+Perl application will have to manage NULL termination itself. When you
+write to the database you will have to use something like this:
+
+ $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+## nullFilter
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+ $hash{12345} = "something" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+## intFilter
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 Using BerkeleyDB with MLDBM
+
+Both BerkeleyDB::Hash and BerkeleyDB::Btree can be used with the MLDBM
+module. The code fragment below shows how to open associate MLDBM with
+BerkeleyDB::Btree. To use BerkeleyDB::Hash just replace
+BerkeleyDB::Btree with BerkeleyDB::Hash.
+
+ use strict ;
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Btree) ;
+ use Data::Dumper;
+
+ my $filename = 'testmldbm' ;
+ my %o ;
+
+ unlink $filename ;
+ tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open database '$filename: $!\n";
+
+See the MLDBM documentation for information on how to use the module
+and for details of its limitations.
+
+=head1 EXAMPLES
+
+TODO.
+
+=head1 HINTS & TIPS
+
+=head2 Sharing Databases With C Applications
+
+There is no technical reason why a Berkeley DB database cannot be
+shared by both a Perl and a C application.
+
+The vast majority of problems that are reported in this area boil down
+to the fact that C strings are NULL terminated, whilst Perl strings
+are not. See L<An Example -- the NULL termination problem.> in the DBM
+FILTERS section for a generic way to work around this problem.
+
+
+=head2 The untie Gotcha
+
+TODO
+
+=head1 COMMON QUESTIONS
+
+This section attempts to answer some of the more common questions that
+I get asked.
+
+
+=head2 Relationship with DB_File
+
+Before Berkeley DB 2.x was written there was only one Perl module that
+interfaced to Berkeley DB. That module is called B<DB_File>. Although
+B<DB_File> can be build with Berkeley DB 1.x, 2.x, 3.x or 4.x, it only
+provides an interface to the functionality available in Berkeley DB
+1.x. That means that it doesn't support transactions, locking or any of
+the other new features available in DB 2.x or better.
+
+=head2 How do I store Perl data structures with BerkeleyDB?
+
+See L<Using BerkeleyDB with MLDBM>.
+
+=head1 HISTORY
+
+See the Changes file.
+
+=head1 AVAILABILITY
+
+The most recent version of B<BerkeleyDB> can always be found
+on CPAN (see L<perlmod/CPAN> for details), in the directory
+F<modules/by-module/BerkeleyDB>.
+
+The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2004 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<BerkeleyDB> 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.
+
+Here are few words taken from the Berkeley DB FAQ (at
+F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+
+ Do I have to license DB to use it in Perl scripts?
+
+ 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 BerkeleyDB.
+See L<"AUTHOR"> for details.
+
+
+=head1 AUTHOR
+
+Paul Marquess E<lt>pmqs@cpan.orgE<gt>.
+
+
+=head1 SEE ALSO
+
+perl(1), DB_File, Berkeley DB.
+
+=cut
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB.xs b/lang/perl/BerkeleyDB/BerkeleyDB.xs
new file mode 100644
index 00000000..9290487d
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB.xs
@@ -0,0 +1,5662 @@
+/*
+
+ BerkeleyDB.xs -- Perl 5 interface to Berkeley DB version 2, 3 & 4
+
+ written by Paul Marquess <pmqs@cpan.org>
+
+ All comments/suggestions/problems are welcome
+
+ Copyright (c) 1997-2011 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.
+
+ Please refer to the COPYRIGHT section in
+
+ Changes:
+ 0.01 - First Alpha Release
+ 0.02 -
+
+*/
+
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define PERL_POLLUTE
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+
+
+/* XSUB.h defines a macro called abort */
+/* This clashes with the txn abort method in Berkeley DB 4.x */
+/* This is a problem with ActivePerl (at least) */
+
+#ifdef _WIN32
+# ifdef abort
+# undef abort
+# endif
+# ifdef fopen
+# undef fopen
+# endif
+# ifdef fclose
+# undef fclose
+# endif
+# ifdef rename
+# undef rename
+# endif
+# ifdef open
+# undef open
+# endif
+#endif
+
+#ifndef SvUTF8_off
+# define SvUTF8_off(x)
+#endif
+
+/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
+ * shortly #included by the <db.h>) __attribute__ to the possibly
+ * already defined __attribute__, for example by GNUC or by Perl. */
+
+#undef __attribute__
+
+#ifdef USE_PERLIO
+# define GetFILEptr(sv) PerlIO_findFILE(IoIFP(sv_2io(sv)))
+#else
+# define GetFILEptr(sv) IoIFP(sv_2io(sv))
+#endif
+
+#include <db.h>
+
+/* Check the version of Berkeley DB */
+
+#ifndef DB_VERSION_MAJOR
+#ifdef HASHMAGIC
+#error db.h is from Berkeley DB 1.x - need at least Berkeley DB 2.6.4
+#else
+#error db.h is not for Berkeley DB at all.
+#endif
+#endif
+
+#if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6) ||\
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 6 && DB_VERSION_PATCH < 4)
+# error db.h is from Berkeley DB 2.0-2.5 - need at least Berkeley DB 2.6.4
+#endif
+
+
+#if (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0)
+# define IS_DB_3_0_x
+#endif
+
+#if DB_VERSION_MAJOR >= 3
+# define AT_LEAST_DB_3
+#endif
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 1)
+# define AT_LEAST_DB_3_1
+#endif
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
+# define AT_LEAST_DB_3_2
+#endif
+
+#if DB_VERSION_MAJOR > 3 || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 2) ||\
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 2 && DB_VERSION_PATCH >= 6)
+# define AT_LEAST_DB_3_2_6
+#endif
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_3_3
+#endif
+
+#if DB_VERSION_MAJOR >= 4
+# define AT_LEAST_DB_4
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
+# define AT_LEAST_DB_4_1
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 2)
+# define AT_LEAST_DB_4_2
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_4_3
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 4)
+# define AT_LEAST_DB_4_4
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 5)
+# define AT_LEAST_DB_4_5
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 6)
+# define AT_LEAST_DB_4_6
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 7)
+# define AT_LEAST_DB_4_7
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 8)
+# define AT_LEAST_DB_4_8
+#endif
+
+#if DB_VERSION_MAJOR > 5 || (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR >= 1)
+# define AT_LEAST_DB_5_1
+#endif
+
+#if DB_VERSION_MAJOR > 5 || (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR >= 2)
+# define AT_LEAST_DB_5_2
+#endif
+
+#if DB_VERSION_MAJOR > 5 || (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_5_3
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#define DBM_FILTERING
+#define STRICT_CLOSE
+/* #define ALLOW_RECNO_OFFSET */
+/* #define TRACE */
+
+#if DB_VERSION_MAJOR == 2 && ! defined(DB_LOCK_DEADLOCK)
+# define DB_LOCK_DEADLOCK EAGAIN
+#endif /* DB_VERSION_MAJOR == 2 */
+
+#if DB_VERSION_MAJOR == 2
+# define DB_QUEUE 4
+#endif /* DB_VERSION_MAJOR == 2 */
+
+#if DB_VERSION_MAJOR == 2
+# define BackRef internal
+#else
+# if DB_VERSION_MAJOR == 3 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0)
+# define BackRef cj_internal
+# else
+# define BackRef api_internal
+# endif
+#endif
+
+#ifdef AT_LEAST_DB_3_2
+# define DB_callback DB * db,
+#else
+# define DB_callback
+#endif
+
+#if DB_VERSION_MAJOR > 2
+typedef struct {
+ int db_lorder;
+ size_t db_cachesize;
+ size_t db_pagesize;
+
+
+ void *(*db_malloc) __P((size_t));
+ int (*dup_compare)
+ __P((DB_callback const DBT *, const DBT *));
+
+ u_int32_t bt_maxkey;
+ u_int32_t bt_minkey;
+ int (*bt_compare)
+ __P((DB_callback const DBT *, const DBT *));
+ size_t (*bt_prefix)
+ __P((DB_callback const DBT *, const DBT *));
+
+ u_int32_t h_ffactor;
+ u_int32_t h_nelem;
+ u_int32_t (*h_hash)
+ __P((DB_callback const void *, u_int32_t));
+
+ int re_pad;
+ int re_delim;
+ u_int32_t re_len;
+ char *re_source;
+
+#define DB_DELIMITER 0x0001
+#define DB_FIXEDLEN 0x0008
+#define DB_PAD 0x0010
+ u_int32_t flags;
+ u_int32_t q_extentsize;
+
+ u_int32_t heapsize_gbytes;
+ u_int32_t heapsize_bytes;
+} DB_INFO ;
+
+#endif /* DB_VERSION_MAJOR > 2 */
+
+typedef struct {
+ int Status ;
+ /* char ErrBuff[1000] ; */
+ SV * ErrPrefix ;
+ SV * ErrHandle ;
+#ifdef AT_LEAST_DB_4_3
+ SV * MsgHandle ;
+#endif
+ DB_ENV * Env ;
+ int open_dbs ;
+ int TxnMgrStatus ;
+ int active ;
+ bool txn_enabled ;
+ bool opened ;
+ bool cds_enabled;
+ } BerkeleyDB_ENV_type ;
+
+
+typedef struct {
+ DBTYPE type ;
+ bool recno_or_queue ;
+ char * filename ;
+ BerkeleyDB_ENV_type * parent_env ;
+ DB * dbp ;
+ SV * compare ;
+ bool in_compare ;
+ SV * dup_compare ;
+ bool in_dup_compare ;
+ SV * prefix ;
+ bool in_prefix ;
+ SV * hash ;
+ bool in_hash ;
+#ifdef AT_LEAST_DB_3_3
+ SV * associated ;
+ bool secondary_db ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ SV * associated_foreign ;
+ SV * bt_compress ;
+ SV * bt_uncompress ;
+#endif
+ bool primary_recno_or_queue ;
+ int Status ;
+ DB_INFO * info ;
+ DBC * cursor ;
+ DB_TXN * txn ;
+ int open_cursors ;
+#ifdef AT_LEAST_DB_4_3
+ int open_sequences ;
+#endif
+ u_int32_t partial ;
+ u_int32_t dlen ;
+ u_int32_t doff ;
+ int active ;
+ bool cds_enabled;
+#ifdef ALLOW_RECNO_OFFSET
+ int array_base ;
+#endif
+#ifdef DBM_FILTERING
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+#endif
+ } BerkeleyDB_type;
+
+
+typedef struct {
+ DBTYPE type ;
+ bool recno_or_queue ;
+ char * filename ;
+ DB * dbp ;
+ SV * compare ;
+ SV * dup_compare ;
+ SV * prefix ;
+ SV * hash ;
+#ifdef AT_LEAST_DB_3_3
+ SV * associated ;
+ bool secondary_db ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ SV * associated_foreign ;
+#endif
+ bool primary_recno_or_queue ;
+ int Status ;
+ DB_INFO * info ;
+ DBC * cursor ;
+ DB_TXN * txn ;
+ BerkeleyDB_type * parent_db ;
+ u_int32_t partial ;
+ u_int32_t dlen ;
+ u_int32_t doff ;
+ int active ;
+ bool cds_enabled;
+#ifdef ALLOW_RECNO_OFFSET
+ int array_base ;
+#endif
+#ifdef DBM_FILTERING
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+#endif
+ } BerkeleyDB_Cursor_type;
+
+typedef struct {
+ BerkeleyDB_ENV_type * env ;
+ } BerkeleyDB_TxnMgr_type ;
+
+#if 1
+typedef struct {
+ int Status ;
+ DB_TXN * txn ;
+ int active ;
+ } BerkeleyDB_Txn_type ;
+#else
+typedef DB_TXN BerkeleyDB_Txn_type ;
+#endif
+
+#ifdef AT_LEAST_DB_4_3
+typedef struct {
+ int active;
+ BerkeleyDB_type *db;
+ DB_SEQUENCE *seq;
+} BerkeleyDB_Sequence_type;
+#else
+typedef int BerkeleyDB_Sequence_type;
+typedef SV* db_seq_t;
+#endif
+
+
+typedef BerkeleyDB_ENV_type * BerkeleyDB__Env ;
+typedef BerkeleyDB_ENV_type * BerkeleyDB__Env__Raw ;
+typedef BerkeleyDB_ENV_type * BerkeleyDB__Env__Inner ;
+typedef BerkeleyDB_type * BerkeleyDB ;
+typedef void * BerkeleyDB__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Common ;
+typedef BerkeleyDB_type * BerkeleyDB__Common__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Common__Inner ;
+typedef BerkeleyDB_type * BerkeleyDB__Hash ;
+typedef BerkeleyDB_type * BerkeleyDB__Hash__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Btree ;
+typedef BerkeleyDB_type * BerkeleyDB__Btree__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Recno ;
+typedef BerkeleyDB_type * BerkeleyDB__Recno__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Queue ;
+typedef BerkeleyDB_type * BerkeleyDB__Queue__Raw ;
+typedef BerkeleyDB_type * BerkeleyDB__Heap ;
+typedef BerkeleyDB_type * BerkeleyDB__Heap__Raw ;
+typedef BerkeleyDB_Cursor_type BerkeleyDB__Cursor_type ;
+typedef BerkeleyDB_Cursor_type * BerkeleyDB__Cursor ;
+typedef BerkeleyDB_Cursor_type * BerkeleyDB__Cursor__Raw ;
+typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr ;
+typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr__Raw ;
+typedef BerkeleyDB_TxnMgr_type * BerkeleyDB__TxnMgr__Inner ;
+typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn ;
+typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Raw ;
+typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Inner ;
+#ifdef AT_LEAST_DB_4_3
+typedef BerkeleyDB_Sequence_type * BerkeleyDB__Sequence ;
+#else
+typedef int * BerkeleyDB__Sequence ;
+#endif
+#if 0
+typedef DB_LOG * BerkeleyDB__Log ;
+typedef DB_LOCKTAB * BerkeleyDB__Lock ;
+#endif
+typedef DBT DBTKEY ;
+typedef DBT DBT_OPT ;
+typedef DBT DBT_B ;
+typedef DBT DBTKEY_B ;
+typedef DBT DBTKEY_Br ;
+typedef DBT DBTKEY_Bpr ;
+typedef DBT DBTKEY_seq ;
+typedef DBT DBTVALUE ;
+typedef void * PV_or_NULL ;
+typedef PerlIO * IO_or_NULL ;
+typedef int DualType ;
+typedef SV SVnull;
+
+static void
+hash_delete(char * hash, char * key);
+
+#ifdef TRACE
+# define Trace(x) (printf("# "), printf x)
+#else
+# define Trace(x)
+#endif
+
+#ifdef ALLOW_RECNO_OFFSET
+# define RECNO_BASE db->array_base
+#else
+# define RECNO_BASE 1
+#endif
+
+#if DB_VERSION_MAJOR == 2
+# define flagSet_DB2(i, f) i |= f
+#else
+# define flagSet_DB2(i, f)
+#endif
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+# define flagSet(bitmask) (flags & (bitmask))
+#else
+# define flagSet(bitmask) ((flags & DB_OPFLAGS_MASK) == (bitmask))
+#endif
+
+#ifdef DB_GET_BOTH_RANGE
+# define flagSetBoth() (flagSet(DB_GET_BOTH) || flagSet(DB_GET_BOTH_RANGE))
+#else
+# define flagSetBoth() (flagSet(DB_GET_BOTH))
+#endif
+
+#ifndef AT_LEAST_DB_4
+typedef int db_timeout_t ;
+#endif
+
+#ifdef AT_LEAST_DB_5_2
+
+# define isHeapDb(db) ((db)->type == DB_HEAP)
+#else
+# define isHeapDb(db) (0)
+
+ int __heap_exist __P((void));
+# define DB_HEAP_RID_SZ 1
+
+
+#endif
+
+#define ERR_BUFF "BerkeleyDB::Error"
+
+#define ZMALLOC(to, typ) ((to = (typ *)safemalloc(sizeof(typ))), \
+ Zero(to,1,typ))
+
+#define DBT_clear(x) Zero(&x, 1, DBT) ;
+
+#if 1
+#define getInnerObject(x) (*av_fetch((AV*)SvRV(x), 0, FALSE))
+#else
+#define getInnerObject(x) ((SV*)SvRV(sv))
+#endif
+
+#define my_sv_setpvn(sv, d, s) do { \
+ s ? sv_setpvn(sv, d, s) : sv_setpv(sv, ""); \
+ SvUTF8_off(sv); \
+ } while(0)
+
+#define GetValue_iv(h,k) (((sv = readHash(h, k)) && sv != &PL_sv_undef) \
+ ? SvIV(sv) : 0)
+#define SetValue_iv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \
+ i = SvIV(sv)
+#define SetValue_io(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \
+ i = GetFILEptr(sv)
+#define SetValue_sv(i, k) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \
+ i = sv
+#define SetValue_pv(i, k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \
+ i = (t)SvPV(sv,PL_na)
+#define SetValue_pvx(i, k, t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) \
+ i = (t)SvPVX(sv)
+#define SetValue_ov(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\
+ IV tmp = SvIV(getInnerObject(sv)) ; \
+ i = INT2PTR(t, tmp) ; \
+ }
+
+#define SetValue_ovx(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\
+ HV * hv = (HV *)GetInternalObject(sv); \
+ SV ** svp = hv_fetch(hv, "db", 2, FALSE);\
+ IV tmp = SvIV(*svp); \
+ i = INT2PTR(t, tmp) ; \
+ }
+
+#define SetValue_ovX(i,k,t) if ((sv = readHash(hash, k)) && sv != &PL_sv_undef) {\
+ IV tmp = SvIV(GetInternalObject(sv));\
+ i = INT2PTR(t, tmp) ; \
+ }
+
+#define LastDBerror DB_RUNRECOVERY
+
+#define setDUALerrno(var, err) \
+ sv_setnv(var, (double)err) ; \
+ sv_setpv(var, ((err) ? db_strerror(err) : "")) ;\
+ SvNOK_on(var);
+
+#define OutputValue(arg, name) \
+ { if (RETVAL == 0) { \
+ my_sv_setpvn(arg, name.data, name.size) ; \
+ DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
+ } \
+ }
+
+#define OutputValue_B(arg, name) \
+ { if (RETVAL == 0) { \
+ if (db->type == DB_BTREE && \
+ flagSet(DB_GET_RECNO)){ \
+ sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \
+ } \
+ else { \
+ my_sv_setpvn(arg, name.data, name.size) ; \
+ } \
+ DBM_ckFilter(arg, filter_fetch_value, "filter_fetch_value"); \
+ } \
+ }
+
+#define OutputKey(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (!db->recno_or_queue) { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ else \
+ sv_setiv(arg, (I32)*(I32*)name.data - RECNO_BASE); \
+ if (! isHeapDb(db)) \
+ DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \
+ } \
+ }
+
+#ifdef AT_LEAST_DB_4_3
+
+#define InputKey_seq(arg, var) \
+ { \
+ SV* my_sv = arg ; \
+ /* DBM_ckFilter(my_sv, filter_store_key, "filter_store_key"); */ \
+ DBT_clear(var) ; \
+ SvGETMAGIC(arg) ; \
+ if (seq->db->recno_or_queue) { \
+ Value = GetRecnoKey(seq->db, SvIV(my_sv)) ; \
+ var.data = & Value; \
+ var.size = (int)sizeof(db_recno_t); \
+ } \
+ else { \
+ STRLEN len; \
+ var.data = SvPV(my_sv, len); \
+ var.size = (int)len; \
+ } \
+ }
+
+#define OutputKey_seq(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (!seq->db->recno_or_queue) { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ else \
+ sv_setiv(arg, (I32)*(I32*)name.data - RECNO_BASE); \
+ } \
+ }
+#else
+#define InputKey_seq(arg, var)
+#define OutputKey_seq(arg, name)
+#endif
+
+#define OutputKey_B(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (db->recno_or_queue \
+ || (db->type == DB_BTREE && \
+ flagSet(DB_GET_RECNO))){ \
+ sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \
+ } \
+ else { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \
+ } \
+ }
+
+#define OutputKey_Br(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (db->recno_or_queue || db->primary_recno_or_queue \
+ || (db->type == DB_BTREE && \
+ flagSet(DB_GET_RECNO))){ \
+ sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \
+ } \
+ else { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \
+ } \
+ }
+
+#define OutputKey_Bpr(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (db->primary_recno_or_queue \
+ || (db->type == DB_BTREE && \
+ flagSet(DB_GET_RECNO))){ \
+ sv_setiv(arg, (I32)(*(I32*)name.data) - RECNO_BASE); \
+ } \
+ else { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ DBM_ckFilter(arg, filter_fetch_key, "filter_fetch_key") ; \
+ } \
+ }
+
+#define SetPartial(data,db) \
+ data.flags = db->partial ; \
+ data.dlen = db->dlen ; \
+ data.doff = db->doff ;
+
+#define ckActive(active, type) \
+ { \
+ if (!active) \
+ softCrash("%s is already closed", type) ; \
+ }
+
+#define ckActive_Environment(a) ckActive(a, "Environment")
+#define ckActive_TxnMgr(a) ckActive(a, "Transaction Manager")
+#define ckActive_Transaction(a) ckActive(a, "Transaction")
+#define ckActive_Database(a) ckActive(a, "Database")
+#define ckActive_Cursor(a) ckActive(a, "Cursor")
+#ifdef AT_LEAST_DB_4_3
+#define ckActive_Sequence(a) ckActive(a, "Sequence")
+#else
+#define ckActive_Sequence(a)
+#endif
+
+#define dieIfEnvOpened(e, m) if (e->opened) softCrash("Cannot call method BerkeleyDB::Env::%s after environment has been opened", m);
+
+#define isSTDOUT_ERR(f) ((f) == stdout || (f) == stderr)
+
+
+/* Internal Global Data */
+#define MY_CXT_KEY "BerkeleyDB::_guts" XS_VERSION
+
+typedef struct {
+ db_recno_t x_Value;
+ db_recno_t x_zero;
+ DBTKEY x_empty;
+#ifndef AT_LEAST_DB_3_2
+ BerkeleyDB x_CurrentDB;
+#endif
+} my_cxt_t;
+
+START_MY_CXT
+
+#define Value (MY_CXT.x_Value)
+#define zero (MY_CXT.x_zero)
+#define empty (MY_CXT.x_empty)
+
+#ifdef AT_LEAST_DB_3_2
+# define CurrentDB ((BerkeleyDB)db->BackRef)
+#else
+# define CurrentDB (MY_CXT.x_CurrentDB)
+#endif
+
+#ifdef AT_LEAST_DB_3_2
+# define getCurrentDB ((BerkeleyDB)db->BackRef)
+# define saveCurrentDB(db)
+#else
+# define getCurrentDB (MY_CXT.x_CurrentDB)
+# define saveCurrentDB(db) (MY_CXT.x_CurrentDB) = db
+#endif
+
+#if 0
+static char ErrBuff[1000] ;
+#endif
+
+#ifdef AT_LEAST_DB_3_3
+# if PERL_REVISION == 5 && PERL_VERSION <= 4
+
+/* saferealloc in perl5.004 will croak if it is given a NULL pointer*/
+void *
+MyRealloc(void * ptr, size_t size)
+{
+ if (ptr == NULL )
+ return safemalloc(size) ;
+ else
+ return saferealloc(ptr, size) ;
+}
+
+# else
+# define MyRealloc saferealloc
+# endif
+#endif
+
+static char *
+my_strdup(const char *s)
+{
+ if (s == NULL)
+ return NULL ;
+
+ {
+ MEM_SIZE l = strlen(s) + 1;
+ char *s1 = (char *)safemalloc(l);
+
+ Copy(s, s1, (MEM_SIZE)l, char);
+ return s1;
+ }
+}
+
+#if DB_VERSION_MAJOR == 2
+static char *
+db_strerror(int err)
+{
+ if (err == 0)
+ return "" ;
+
+ if (err > 0)
+ return Strerror(err) ;
+
+ switch (err) {
+ case DB_INCOMPLETE:
+ return ("DB_INCOMPLETE: Sync was unable to complete");
+ case DB_KEYEMPTY:
+ return ("DB_KEYEMPTY: Non-existent key/data pair");
+ case DB_KEYEXIST:
+ return ("DB_KEYEXIST: Key/data pair already exists");
+ case DB_LOCK_DEADLOCK:
+ return (
+ "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock");
+ case DB_LOCK_NOTGRANTED:
+ return ("DB_LOCK_NOTGRANTED: Lock not granted");
+ case DB_LOCK_NOTHELD:
+ return ("DB_LOCK_NOTHELD: Lock not held by locker");
+ case DB_NOTFOUND:
+ return ("DB_NOTFOUND: No matching key/data pair found");
+ case DB_RUNRECOVERY:
+ return ("DB_RUNRECOVERY: Fatal error, run database recovery");
+ default:
+ return "Unknown Error" ;
+
+ }
+}
+#endif /* DB_VERSION_MAJOR == 2 */
+
+#ifdef TRACE
+#if DB_VERSION_MAJOR > 2
+static char *
+my_db_strerror(int err)
+{
+ static char buffer[1000] ;
+ SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
+ sprintf(buffer, "%d: %s", err, db_strerror(err)) ;
+ if (err && sv) {
+ strcat(buffer, ", ") ;
+ strcat(buffer, SvPVX(sv)) ;
+ }
+ return buffer;
+}
+#endif
+#endif
+
+static void
+close_everything(void)
+{
+ dTHR;
+ Trace(("close_everything\n")) ;
+ /* Abort All Transactions */
+ {
+ BerkeleyDB__Txn__Raw tid ;
+ HE * he ;
+ I32 len ;
+ HV * hv = perl_get_hv("BerkeleyDB::Term::Txn", TRUE);
+ int all = 0 ;
+ int closed = 0 ;
+ (void)hv_iterinit(hv) ;
+ Trace(("BerkeleyDB::Term::close_all_txns dirty=%d\n", PL_dirty)) ;
+ while ( (he = hv_iternext(hv)) ) {
+ tid = * (BerkeleyDB__Txn__Raw *) hv_iterkey(he, &len) ;
+ Trace((" Aborting Transaction [%d] in [%d] Active [%d]\n", tid->txn, tid, tid->active));
+ if (tid->active) {
+#ifdef AT_LEAST_DB_4
+ tid->txn->abort(tid->txn) ;
+#else
+ txn_abort(tid->txn);
+#endif
+ ++ closed ;
+ }
+ tid->active = FALSE ;
+ ++ all ;
+ }
+ Trace(("End of BerkeleyDB::Term::close_all_txns aborted %d of %d transactios\n",closed, all)) ;
+ }
+
+ /* Close All Cursors */
+ {
+ BerkeleyDB__Cursor db ;
+ HE * he ;
+ I32 len ;
+ HV * hv = perl_get_hv("BerkeleyDB::Term::Cursor", TRUE);
+ int all = 0 ;
+ int closed = 0 ;
+ (void) hv_iterinit(hv) ;
+ Trace(("BerkeleyDB::Term::close_all_cursors \n")) ;
+ while ( (he = hv_iternext(hv)) ) {
+ db = * (BerkeleyDB__Cursor*) hv_iterkey(he, &len) ;
+ Trace((" Closing Cursor [%d] in [%d] Active [%d]\n", db->cursor, db, db->active));
+ if (db->active) {
+ ((db->cursor)->c_close)(db->cursor) ;
+ ++ closed ;
+ }
+ db->active = FALSE ;
+ ++ all ;
+ }
+ Trace(("End of BerkeleyDB::Term::close_all_cursors closed %d of %d cursors\n",closed, all)) ;
+ }
+
+ /* Close All Databases */
+ {
+ BerkeleyDB db ;
+ HE * he ;
+ I32 len ;
+ HV * hv = perl_get_hv("BerkeleyDB::Term::Db", TRUE);
+ int all = 0 ;
+ int closed = 0 ;
+ (void)hv_iterinit(hv) ;
+ Trace(("BerkeleyDB::Term::close_all_dbs\n" )) ;
+ while ( (he = hv_iternext(hv)) ) {
+ db = * (BerkeleyDB*) hv_iterkey(he, &len) ;
+ Trace((" Closing Database [%d] in [%d] Active [%d]\n", db->dbp, db, db->active));
+ if (db->active) {
+ (db->dbp->close)(db->dbp, 0) ;
+ ++ closed ;
+ }
+ db->active = FALSE ;
+ ++ all ;
+ }
+ Trace(("End of BerkeleyDB::Term::close_all_dbs closed %d of %d dbs\n",closed, all)) ;
+ }
+
+ /* Close All Environments */
+ {
+ BerkeleyDB__Env env ;
+ HE * he ;
+ I32 len ;
+ HV * hv = perl_get_hv("BerkeleyDB::Term::Env", TRUE);
+ int all = 0 ;
+ int closed = 0 ;
+ (void)hv_iterinit(hv) ;
+ Trace(("BerkeleyDB::Term::close_all_envs\n")) ;
+ while ( (he = hv_iternext(hv)) ) {
+ env = * (BerkeleyDB__Env*) hv_iterkey(he, &len) ;
+ Trace((" Closing Environment [%d] in [%d] Active [%d]\n", env->Env, env, env->active));
+ if (env->active) {
+#if DB_VERSION_MAJOR == 2
+ db_appexit(env->Env) ;
+#else
+ (env->Env->close)(env->Env, 0) ;
+#endif
+ ++ closed ;
+ }
+ env->active = FALSE ;
+ ++ all ;
+ }
+ Trace(("End of BerkeleyDB::Term::close_all_envs closed %d of %d dbs\n",closed, all)) ;
+ }
+
+ Trace(("end close_everything\n")) ;
+
+}
+
+static void
+destroyDB(BerkeleyDB db)
+{
+ dTHR;
+ if (! PL_dirty && db->active) {
+ if (db->parent_env && db->parent_env->open_dbs)
+ -- db->parent_env->open_dbs ;
+ -- db->open_cursors ;
+ ((db->dbp)->close)(db->dbp, 0) ;
+ }
+ if (db->hash)
+ SvREFCNT_dec(db->hash) ;
+ if (db->compare)
+ SvREFCNT_dec(db->compare) ;
+ if (db->dup_compare)
+ SvREFCNT_dec(db->dup_compare) ;
+#ifdef AT_LEAST_DB_3_3
+ if (db->associated && !db->secondary_db)
+ SvREFCNT_dec(db->associated) ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ if (db->associated_foreign)
+ SvREFCNT_dec(db->associated_foreign) ;
+#endif
+ if (db->prefix)
+ SvREFCNT_dec(db->prefix) ;
+#ifdef DBM_FILTERING
+ if (db->filter_fetch_key)
+ SvREFCNT_dec(db->filter_fetch_key) ;
+ if (db->filter_store_key)
+ SvREFCNT_dec(db->filter_store_key) ;
+ if (db->filter_fetch_value)
+ SvREFCNT_dec(db->filter_fetch_value) ;
+ if (db->filter_store_value)
+ SvREFCNT_dec(db->filter_store_value) ;
+#endif
+ hash_delete("BerkeleyDB::Term::Db", (char *)db) ;
+ if (db->filename)
+ Safefree(db->filename) ;
+ Safefree(db) ;
+}
+
+static int
+softCrash(const char *pat, ...)
+{
+ char buffer1 [500] ;
+ char buffer2 [500] ;
+ va_list args;
+ va_start(args, pat);
+
+ Trace(("softCrash: %s\n", pat)) ;
+
+#define ABORT_PREFIX "BerkeleyDB Aborting: "
+
+ /* buffer = (char*) safemalloc(strlen(pat) + strlen(ABORT_PREFIX) + 1) ; */
+ strcpy(buffer1, ABORT_PREFIX) ;
+ strcat(buffer1, pat) ;
+
+ vsprintf(buffer2, buffer1, args) ;
+
+ croak(buffer2);
+
+ /* NOTREACHED */
+ va_end(args);
+ return 1 ;
+}
+
+
+static I32
+GetArrayLength(BerkeleyDB db)
+{
+ DBT key ;
+ DBT value ;
+ int RETVAL = 0 ;
+ DBC * cursor ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
+ if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor) == 0 )
+#else
+ if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor, 0) == 0 )
+#endif
+ {
+ RETVAL = cursor->c_get(cursor, &key, &value, DB_LAST) ;
+ if (RETVAL == 0)
+ RETVAL = *(I32 *)key.data ;
+ else /* No key means empty file */
+ RETVAL = 0 ;
+ cursor->c_close(cursor) ;
+ }
+
+ Trace(("GetArrayLength got %d\n", RETVAL)) ;
+ return ((I32)RETVAL) ;
+}
+
+#if 0
+
+#define GetRecnoKey(db, value) _GetRecnoKey(db, value)
+
+static db_recno_t
+_GetRecnoKey(BerkeleyDB db, I32 value)
+{
+ Trace(("GetRecnoKey start value = %d\n", value)) ;
+ if (db->recno_or_queue && value < 0) {
+ /* Get the length of the array */
+ I32 length = GetArrayLength(db) ;
+
+ /* check for attempt to write before start of array */
+ if (length + value + RECNO_BASE <= 0)
+ softCrash("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
+
+ value = length + value + RECNO_BASE ;
+ }
+ else
+ ++ value ;
+
+ Trace(("GetRecnoKey end value = %d\n", value)) ;
+
+ return value ;
+}
+
+#else /* ! 0 */
+
+#if 0
+#ifdef ALLOW_RECNO_OFFSET
+#define GetRecnoKey(db, value) _GetRecnoKey(db, value)
+
+static db_recno_t
+_GetRecnoKey(BerkeleyDB db, I32 value)
+{
+ if (value + RECNO_BASE < 1)
+ softCrash("key value %d < base (%d)", (value), RECNO_BASE?0:1) ;
+ return value + RECNO_BASE ;
+}
+
+#else
+#endif /* ALLOW_RECNO_OFFSET */
+#endif /* 0 */
+
+#define GetRecnoKey(db, value) ((value) + RECNO_BASE )
+
+#endif /* 0 */
+
+#if 0
+static SV *
+GetInternalObject(SV * sv)
+{
+ SV * info = (SV*) NULL ;
+ SV * s ;
+ MAGIC * mg ;
+
+ Trace(("in GetInternalObject %d\n", sv)) ;
+ if (sv == NULL || !SvROK(sv))
+ return NULL ;
+
+ s = SvRV(sv) ;
+ if (SvMAGICAL(s))
+ {
+ if (SvTYPE(s) == SVt_PVHV || SvTYPE(s) == SVt_PVAV)
+ mg = mg_find(s, 'P') ;
+ else
+ mg = mg_find(s, 'q') ;
+
+ /* all this testing is probably overkill, but till I know more
+ about global destruction it stays.
+ */
+ /* if (mg && mg->mg_obj && SvRV(mg->mg_obj) && SvPVX(SvRV(mg->mg_obj))) */
+ if (mg && mg->mg_obj && SvRV(mg->mg_obj) )
+ info = SvRV(mg->mg_obj) ;
+ else
+ info = s ;
+ }
+
+ Trace(("end of GetInternalObject %d\n", info)) ;
+ return info ;
+}
+#endif
+
+static int
+btree_compare(DB_callback const DBT * key1, const DBT * key2 )
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * data1, * data2 ;
+ int retval ;
+ int count ;
+ /* BerkeleyDB keepDB = getCurrentDB ; */
+
+ Trace(("In btree_compare \n")) ;
+ data1 = (char*) key1->data ;
+ data2 = (char*) key2->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ /* SAVESPTR(CurrentDB); */
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(getCurrentDB->compare, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("in btree_compare - expected 1 return value from compare sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ /* CurrentDB = keepDB ; */
+ return (retval) ;
+
+}
+
+static int
+dup_compare(DB_callback const DBT * key1, const DBT * key2 )
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * data1, * data2 ;
+ int retval ;
+ int count ;
+ /* BerkeleyDB keepDB = CurrentDB ; */
+
+ Trace(("In dup_compare \n")) ;
+ if (!getCurrentDB)
+ softCrash("Internal Error - No CurrentDB in dup_compare") ;
+ if (getCurrentDB->dup_compare == NULL)
+
+
+ softCrash("in dup_compare: no callback specified for database '%s'", getCurrentDB->filename) ;
+
+ data1 = (char*) key1->data ;
+ data2 = (char*) key2->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(getCurrentDB->dup_compare, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("dup_compare: expected 1 return value from compare sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ /* CurrentDB = keepDB ; */
+ return (retval) ;
+
+}
+
+static size_t
+btree_prefix(DB_callback const DBT * key1, const DBT * key2 )
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * data1, * data2 ;
+ int retval ;
+ int count ;
+ /* BerkeleyDB keepDB = CurrentDB ; */
+
+ Trace(("In btree_prefix \n")) ;
+ data1 = (char*) key1->data ;
+ data2 = (char*) key2->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(getCurrentDB->prefix, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("btree_prefix: expected 1 return value from prefix sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ /* CurrentDB = keepDB ; */
+
+ return (retval) ;
+}
+
+static u_int32_t
+hash_cb(DB_callback const void * data, u_int32_t size)
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ int retval ;
+ int count ;
+ /* BerkeleyDB keepDB = CurrentDB ; */
+
+ Trace(("In hash_cb \n")) ;
+#ifndef newSVpvn
+ if (size == 0)
+ data = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+
+ XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
+ PUTBACK ;
+
+ count = perl_call_sv(getCurrentDB->hash, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("hash_cb: expected 1 return value from hash sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ /* CurrentDB = keepDB ; */
+
+ return (retval) ;
+}
+
+#ifdef AT_LEAST_DB_3_3
+
+static int
+associate_cb(DB_callback const DBT * pkey, const DBT * pdata, DBT * skey)
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * pk_dat, * pd_dat ;
+ /* char *sk_dat ; */
+ int retval ;
+ int count ;
+ int i ;
+ SV * skey_SV ;
+ STRLEN skey_len;
+ char * skey_ptr ;
+ AV * skey_AV;
+ DBT * tkey;
+
+ Trace(("In associate_cb \n")) ;
+ if (getCurrentDB->associated == NULL){
+ Trace(("No Callback registered\n")) ;
+ return EINVAL ;
+ }
+
+ skey_SV = newSVpv("",0);
+
+
+ pk_dat = (char*) pkey->data ;
+ pd_dat = (char*) pdata->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (pkey->size == 0)
+ pk_dat = "" ;
+ if (pdata->size == 0)
+ pd_dat = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,3) ;
+ PUSHs(sv_2mortal(newSVpvn(pk_dat,pkey->size)));
+ PUSHs(sv_2mortal(newSVpvn(pd_dat,pdata->size)));
+ PUSHs(sv_2mortal(skey_SV));
+ PUTBACK ;
+
+ Trace(("calling associated cb\n"));
+ count = perl_call_sv(getCurrentDB->associated, G_SCALAR);
+ Trace(("called associated cb\n"));
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("associate: expected 1 return value from prefix sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+
+ if (retval != DB_DONOTINDEX)
+ {
+ /* retrieve the secondary key */
+ DBT_clear(*skey);
+
+ skey->flags = DB_DBT_APPMALLOC;
+
+ #ifdef AT_LEAST_DB_4_6
+ if ( SvROK(skey_SV) ) {
+ SV *rv = SvRV(skey_SV);
+
+ if ( SvTYPE(rv) == SVt_PVAV ) {
+ AV *av = (AV *)rv;
+ SV **svs = AvARRAY(av);
+ I32 len = av_len(av) + 1;
+ I32 i;
+ DBT *dbts;
+
+ if ( len == 0 ) {
+ retval = DB_DONOTINDEX;
+ } else if ( len == 1 ) {
+ skey_ptr = SvPV(svs[0], skey_len);
+ skey->size = skey_len;
+ skey->data = (char*)safemalloc(skey_len);
+ memcpy(skey->data, skey_ptr, skey_len);
+ Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));
+ } else {
+ skey->flags |= DB_DBT_MULTIPLE ;
+
+ /* FIXME this will leak if safemalloc fails later... do we care? */
+ dbts = (DBT *) safemalloc(sizeof(DBT) * len);
+ skey->size = len;
+ skey->data = (char *)dbts;
+
+ for ( i = 0; i < skey->size; i ++ ) {
+ skey_ptr = SvPV(svs[i], skey_len);
+
+ dbts[i].flags = DB_DBT_APPMALLOC;
+ dbts[i].size = skey_len;
+ dbts[i].data = (char *)safemalloc(skey_len);
+ memcpy(dbts[i].data, skey_ptr, skey_len);
+
+ Trace(("key is %d -- %.*s\n", dbts[i].size, dbts[i].size, dbts[i].data));
+ }
+ Trace(("mkey has %d subkeys\n", skey->size));
+ }
+ } else {
+ croak("Not an array reference");
+ }
+ } else
+ #endif
+ {
+ skey_ptr = SvPV(skey_SV, skey_len);
+ /* skey->size = SvCUR(skey_SV); */
+ /* skey->data = (char*)safemalloc(skey->size); */
+ skey->size = skey_len;
+ skey->data = (char*)safemalloc(skey_len);
+ memcpy(skey->data, skey_ptr, skey_len);
+ }
+ }
+ Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));
+
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+static int
+associate_cb_recno(DB_callback const DBT * pkey, const DBT * pdata, DBT * skey)
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * pk_dat, * pd_dat ;
+ /* char *sk_dat ; */
+ int retval ;
+ int count ;
+ SV * skey_SV ;
+ STRLEN skey_len;
+ char * skey_ptr ;
+ /* db_recno_t Value; */
+
+ Trace(("In associate_cb_recno \n")) ;
+ if (getCurrentDB->associated == NULL){
+ Trace(("No Callback registered\n")) ;
+ return EINVAL ;
+ }
+
+ skey_SV = newSVpv("",0);
+
+
+ pk_dat = (char*) pkey->data ;
+ pd_dat = (char*) pdata->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (pkey->size == 0)
+ pk_dat = "" ;
+ if (pdata->size == 0)
+ pd_dat = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn(pk_dat,pkey->size)));
+ PUSHs(sv_2mortal(newSVpvn(pd_dat,pdata->size)));
+ PUSHs(sv_2mortal(skey_SV));
+ PUTBACK ;
+
+ Trace(("calling associated cb\n"));
+ count = perl_call_sv(getCurrentDB->associated, G_SCALAR);
+ Trace(("called associated cb\n"));
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("associate: expected 1 return value from prefix sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+
+ /* retrieve the secondary key */
+ DBT_clear(*skey);
+
+ if (retval != DB_DONOTINDEX)
+ {
+ Value = GetRecnoKey(getCurrentDB, SvIV(skey_SV)) ;
+ skey->flags = DB_DBT_APPMALLOC;
+ skey->size = (int)sizeof(db_recno_t);
+ skey->data = (char*)safemalloc(skey->size);
+ memcpy(skey->data, &Value, skey->size);
+ }
+
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+#endif /* AT_LEAST_DB_3_3 */
+
+#ifdef AT_LEAST_DB_4_8
+
+typedef int (*bt_compress_fcn_type)(DB *db, const DBT *prevKey,
+ const DBT *prevData, const DBT *key, const DBT *data, DBT *dest);
+
+typedef int (*bt_decompress_fcn_type)(DB *db, const DBT *prevKey,
+ const DBT *prevData, DBT *compressed, DBT *destKey, DBT *destData);
+
+#endif /* AT_LEAST_DB_4_8 */
+
+typedef int (*foreign_cb_type)(DB *, const DBT *, DBT *, const DBT *, int *) ;
+
+#ifdef AT_LEAST_DB_4_8
+
+static int
+associate_foreign_cb(DB* db, const DBT * key, DBT * data, const DBT * foreignkey, int* changed)
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * k_dat, * d_dat, * f_dat;
+ int retval ;
+ int count ;
+ int i ;
+ SV * changed_SV ;
+ STRLEN skey_len;
+ char * skey_ptr ;
+ AV * skey_AV;
+ DBT * tkey;
+ SV* data_sv ;
+
+ Trace(("In associate_foreign_cb \n")) ;
+ if (getCurrentDB->associated_foreign == NULL){
+ Trace(("No Callback registered\n")) ;
+ return EINVAL ;
+ }
+
+ changed_SV = newSViv(*changed);
+
+
+ k_dat = (char*) key->data ;
+ d_dat = (char*) data->data ;
+ f_dat = (char*) foreignkey->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key->size == 0)
+ k_dat = "" ;
+ if (data->size == 0)
+ d_dat = "" ;
+ if (foreignkey->size == 0)
+ f_dat = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,4) ;
+
+ PUSHs(sv_2mortal(newSVpvn(k_dat,key->size)));
+ data_sv = newSVpv(d_dat, data->size);
+ PUSHs(sv_2mortal(data_sv));
+ PUSHs(sv_2mortal(newSVpvn(f_dat,foreignkey->size)));
+ PUSHs(sv_2mortal(changed_SV));
+ PUTBACK ;
+
+ Trace(("calling associated cb\n"));
+ count = perl_call_sv(getCurrentDB->associated_foreign, G_SCALAR);
+ Trace(("called associated cb\n"));
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("associate_foreign: expected 1 return value from prefix sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+
+ *changed = SvIV(changed_SV);
+
+ if (*changed)
+ {
+ DBT_clear(*data);
+ data->flags = DB_DBT_APPMALLOC;
+ skey_ptr = SvPV(data_sv, skey_len);
+ data->size = skey_len;
+ data->data = (char*)safemalloc(skey_len);
+ memcpy(data->data, skey_ptr, skey_len);
+ }
+ /*Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));*/
+
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+static int
+associate_foreign_cb_recno(DB* db, const DBT * key, DBT * data, const DBT * foreignkey, int* changed)
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * k_dat, * d_dat, * f_dat;
+ int retval ;
+ int count ;
+ int i ;
+ SV * changed_SV ;
+ STRLEN skey_len;
+ char * skey_ptr ;
+ AV * skey_AV;
+ DBT * tkey;
+ SV* data_sv ;
+
+ Trace(("In associate_foreign_cb \n")) ;
+ if (getCurrentDB->associated_foreign == NULL){
+ Trace(("No Callback registered\n")) ;
+ return EINVAL ;
+ }
+
+ changed_SV = newSViv(*changed);
+
+
+ k_dat = (char*) key->data ;
+ d_dat = (char*) data->data ;
+ f_dat = (char*) foreignkey->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key->size == 0)
+ k_dat = "" ;
+ if (data->size == 0)
+ d_dat = "" ;
+ if (foreignkey->size == 0)
+ f_dat = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,4) ;
+
+ PUSHs(sv_2mortal(newSVpvn(k_dat,key->size)));
+ data_sv = newSVpv(d_dat, data->size);
+ PUSHs(sv_2mortal(data_sv));
+ PUSHs(sv_2mortal(newSVpvn(f_dat,foreignkey->size)));
+ PUSHs(sv_2mortal(changed_SV));
+ PUTBACK ;
+
+ Trace(("calling associated cb\n"));
+ count = perl_call_sv(getCurrentDB->associated_foreign, G_SCALAR);
+ Trace(("called associated cb\n"));
+
+ SPAGAIN ;
+
+ if (count != 1)
+ softCrash ("associate_foreign: expected 1 return value from prefix sub, got %d", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+
+ *changed = SvIV(changed_SV);
+
+ if (*changed)
+ {
+ DBT_clear(*data);
+ Value = GetRecnoKey(getCurrentDB, SvIV(data_sv)) ;
+ data->flags = DB_DBT_APPMALLOC;
+ data->size = (int)sizeof(db_recno_t);
+ data->data = (char*)safemalloc(data->size);
+ memcpy(data->data, &Value, data->size);
+ }
+ /*Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));*/
+
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+#endif /* AT_LEAST_DB_3_3 */
+
+static void
+#ifdef AT_LEAST_DB_4_3
+db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
+#else
+db_errcall_cb(const char * db_errpfx, char * buffer)
+#endif
+{
+ SV * sv;
+
+ Trace(("In errcall_cb \n")) ;
+#if 0
+
+ if (db_errpfx == NULL)
+ db_errpfx = "" ;
+ if (buffer == NULL )
+ buffer = "" ;
+ ErrBuff[0] = '\0';
+ if (strlen(db_errpfx) + strlen(buffer) + 3 <= 1000) {
+ if (*db_errpfx != '\0') {
+ strcat(ErrBuff, db_errpfx) ;
+ strcat(ErrBuff, ": ") ;
+ }
+ strcat(ErrBuff, buffer) ;
+ }
+
+#endif
+
+ sv = perl_get_sv(ERR_BUFF, FALSE) ;
+ if (sv) {
+ if (db_errpfx)
+ sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
+ else
+ sv_setpv(sv, buffer) ;
+ }
+}
+
+#if defined(AT_LEAST_DB_4_4) && ! defined(_WIN32)
+
+int
+db_isalive_cb(DB_ENV *dbenv, pid_t pid, db_threadid_t tid, u_int32_t flags)
+{
+ bool processAlive = ( kill(pid, 0) == 0 ) || ( errno != ESRCH );
+ return processAlive;
+}
+
+#endif
+
+
+static SV *
+readHash(HV * hash, char * key)
+{
+ SV ** svp;
+ svp = hv_fetch(hash, key, strlen(key), FALSE);
+
+ if (svp) {
+ if (SvGMAGICAL(*svp))
+ mg_get(*svp);
+ if (SvOK(*svp))
+ return *svp;
+ }
+
+ return NULL ;
+}
+
+static void
+hash_delete(char * hash, char * key)
+{
+ HV * hv = perl_get_hv(hash, TRUE);
+ (void) hv_delete(hv, (char*)&key, sizeof(key), G_DISCARD);
+}
+
+static void
+hash_store_iv(char * hash, char * key, IV value)
+{
+ HV * hv = perl_get_hv(hash, TRUE);
+ (void)hv_store(hv, (char*)&key, sizeof(key), newSViv(value), 0);
+ /* printf("hv_store returned %d\n", ret) ; */
+}
+
+static void
+hv_store_iv(HV * hash, char * key, IV value)
+{
+ hv_store(hash, key, strlen(key), newSViv(value), 0);
+}
+
+#if 0
+static void
+hv_store_uv(HV * hash, char * key, UV value)
+{
+ hv_store(hash, key, strlen(key), newSVuv(value), 0);
+}
+#endif
+
+static void
+GetKey(BerkeleyDB_type * db, SV * sv, DBTKEY * key)
+{
+ dMY_CXT ;
+ if (db->recno_or_queue) {
+ Value = GetRecnoKey(db, SvIV(sv)) ;
+ key->data = & Value;
+ key->size = (int)sizeof(db_recno_t);
+ }
+ else {
+ key->data = SvPV(sv, PL_na);
+ key->size = (int)PL_na;
+ }
+}
+
+static BerkeleyDB
+my_db_open(
+ BerkeleyDB db ,
+ SV * ref,
+ SV * ref_dbenv ,
+ BerkeleyDB__Env dbenv ,
+ BerkeleyDB__Txn txn,
+ const char * file,
+ const char * subname,
+ DBTYPE type,
+ int flags,
+ int mode,
+ DB_INFO * info,
+ char * password,
+ int enc_flags,
+ HV* hash
+ )
+{
+ DB_ENV * env = NULL ;
+ BerkeleyDB RETVAL = NULL ;
+ DB * dbp ;
+ int Status ;
+ DB_TXN* txnid = NULL ;
+ dMY_CXT;
+
+ Trace(("_db_open(dbenv[%p] ref_dbenv [%p] file[%s] subname [%s] type[%d] flags[%d] mode[%d]\n",
+ dbenv, ref_dbenv, file, subname, type, flags, mode)) ;
+
+
+ if (dbenv)
+ env = dbenv->Env ;
+
+ if (txn)
+ txnid = txn->txn;
+
+ Trace(("_db_open(dbenv[%p] ref_dbenv [%p] txn [%p] file[%s] subname [%s] type[%d] flags[%d] mode[%d]\n",
+ dbenv, ref_dbenv, txn, file, subname, type, flags, mode)) ;
+
+#if DB_VERSION_MAJOR == 2
+ if (subname)
+ softCrash("Subname needs Berkeley DB 3 or better") ;
+#endif
+
+#ifndef AT_LEAST_DB_4_1
+ if (password)
+ softCrash("-Encrypt needs Berkeley DB 4.x or better") ;
+#endif /* ! AT_LEAST_DB_4_1 */
+
+#ifndef AT_LEAST_DB_3_2
+ CurrentDB = db ;
+#endif
+
+#if DB_VERSION_MAJOR > 2
+ Trace(("creating\n"));
+ Status = db_create(&dbp, env, 0) ;
+ Trace(("db_create returned %s\n", my_db_strerror(Status))) ;
+ if (Status)
+ return RETVAL ;
+
+#ifdef AT_LEAST_DB_3_2
+ dbp->BackRef = db;
+#endif
+
+#ifdef AT_LEAST_DB_3_3
+ if (! env) {
+ dbp->set_alloc(dbp, safemalloc, MyRealloc, safefree) ;
+ dbp->set_errcall(dbp, db_errcall_cb) ;
+ }
+#endif
+
+ {
+ /* Btree Compression */
+ SV* sv;
+ SV* wanted = NULL;
+
+ SetValue_sv(wanted, "set_bt_compress") ;
+
+ if (wanted)
+ {
+#ifndef AT_LEAST_DB_4_8
+ softCrash("set_bt_compress needs Berkeley DB 4.8 or better") ;
+#else
+ bt_compress_fcn_type c = NULL;
+ bt_decompress_fcn_type u = NULL;
+ /*
+ SV* compress = NULL;
+ SV* uncompress = NULL;
+
+ SetValue_sv(compress, "_btcompress1") ;
+ SetValue_sv(uncompress, "_btcompress2") ;
+ if (compress)
+ {
+ c = ;
+ db->bt_compress = newSVsv(compress) ;
+ }
+ */
+
+ Status = dbp->set_bt_compress(dbp, c, u);
+
+ if (Status)
+ return RETVAL ;
+#endif /* AT_LEAST_DB_4_8 */
+ }
+ }
+
+#ifdef AT_LEAST_DB_4_1
+ /* set encryption */
+ if (password)
+ {
+ Status = dbp->set_encrypt(dbp, password, enc_flags);
+ Trace(("DB->set_encrypt passwd = %s, flags %d returned %s\n",
+ password, enc_flags,
+ my_db_strerror(Status))) ;
+ if (Status)
+ return RETVAL ;
+ }
+#endif
+
+ if (info->re_source) {
+ Status = dbp->set_re_source(dbp, info->re_source) ;
+ Trace(("set_re_source [%s] returned %s\n",
+ info->re_source, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->db_cachesize) {
+ Status = dbp->set_cachesize(dbp, 0, info->db_cachesize, 0) ;
+ Trace(("set_cachesize [%d] returned %s\n",
+ info->db_cachesize, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->db_lorder) {
+ Status = dbp->set_lorder(dbp, info->db_lorder) ;
+ Trace(("set_lorder [%d] returned %s\n",
+ info->db_lorder, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->db_pagesize) {
+ Status = dbp->set_pagesize(dbp, info->db_pagesize) ;
+ Trace(("set_pagesize [%d] returned %s\n",
+ info->db_pagesize, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->h_ffactor) {
+ Status = dbp->set_h_ffactor(dbp, info->h_ffactor) ;
+ Trace(("set_h_ffactor [%d] returned %s\n",
+ info->h_ffactor, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->h_nelem) {
+ Status = dbp->set_h_nelem(dbp, info->h_nelem) ;
+ Trace(("set_h_nelem [%d] returned %s\n",
+ info->h_nelem, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->bt_minkey) {
+ Status = dbp->set_bt_minkey(dbp, info->bt_minkey) ;
+ Trace(("set_bt_minkey [%d] returned %s\n",
+ info->bt_minkey, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->bt_compare) {
+ Status = dbp->set_bt_compare(dbp, info->bt_compare) ;
+ Trace(("set_bt_compare [%p] returned %s\n",
+ info->bt_compare, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->h_hash) {
+ Status = dbp->set_h_hash(dbp, info->h_hash) ;
+ Trace(("set_h_hash [%d] returned %s\n",
+ info->h_hash, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+
+ if (info->dup_compare) {
+ Status = dbp->set_dup_compare(dbp, info->dup_compare) ;
+ Trace(("set_dup_compare [%d] returned %s\n",
+ info->dup_compare, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->bt_prefix) {
+ Status = dbp->set_bt_prefix(dbp, info->bt_prefix) ;
+ Trace(("set_bt_prefix [%d] returned %s\n",
+ info->bt_prefix, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->re_len) {
+ Status = dbp->set_re_len(dbp, info->re_len) ;
+ Trace(("set_re_len [%d] returned %s\n",
+ info->re_len, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->re_delim) {
+ Status = dbp->set_re_delim(dbp, info->re_delim) ;
+ Trace(("set_re_delim [%d] returned %s\n",
+ info->re_delim, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->re_pad) {
+ Status = dbp->set_re_pad(dbp, info->re_pad) ;
+ Trace(("set_re_pad [%d] returned %s\n",
+ info->re_pad, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->flags) {
+ Status = dbp->set_flags(dbp, info->flags) ;
+ Trace(("set_flags [%d] returned %s\n",
+ info->flags, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+ }
+
+ if (info->q_extentsize) {
+#ifdef AT_LEAST_DB_3_2
+ Status = dbp->set_q_extentsize(dbp, info->q_extentsize) ;
+ Trace(("set_q_extentsize [%d] returned %s\n",
+ info->q_extentsize, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+#else
+ softCrash("-ExtentSize needs at least Berkeley DB 3.2.x") ;
+#endif
+ }
+
+ if (info->heapsize_bytes || info->heapsize_gbytes) {
+#ifdef AT_LEAST_DB_5_2
+ Status = dbp->set_heapsize(dbp, info->heapsize_gbytes,
+ info->heapsize_bytes,0) ;
+ Trace(("set_heapsize [%d,%d] returned %s\n",
+ info->heapsize_gbytes, info->heapsize_bytes, my_db_strerror(Status)));
+ if (Status)
+ return RETVAL ;
+#else
+ softCrash("-HeapSize/HeapSizeGb needs at least Berkeley DB 5.2.x") ;
+#endif
+ }
+
+ /* In-memory database need DB_CREATE from 4.4 */
+ if (! file)
+ flags |= DB_CREATE;
+
+ Trace(("db_open'ing\n"));
+
+#ifdef AT_LEAST_DB_4_1
+ if ((Status = (dbp->open)(dbp, txnid, file, subname, type, flags, mode)) == 0) {
+#else
+ if ((Status = (dbp->open)(dbp, file, subname, type, flags, mode)) == 0) {
+#endif /* AT_LEAST_DB_4_1 */
+#else /* DB_VERSION_MAJOR == 2 */
+ if ((Status = db_open(file, type, flags, mode, env, info, &dbp)) == 0) {
+ CurrentDB = db ;
+#endif /* DB_VERSION_MAJOR == 2 */
+
+
+ Trace(("db_opened ok\n"));
+ RETVAL = db ;
+ RETVAL->dbp = dbp ;
+ RETVAL->txn = txnid ;
+#if DB_VERSION_MAJOR == 2
+ RETVAL->type = dbp->type ;
+#else /* DB_VERSION_MAJOR > 2 */
+#ifdef AT_LEAST_DB_3_3
+ dbp->get_type(dbp, &RETVAL->type) ;
+#else /* DB 3.0 -> 3.2 */
+ RETVAL->type = dbp->get_type(dbp) ;
+#endif
+#endif /* DB_VERSION_MAJOR > 2 */
+ RETVAL->primary_recno_or_queue = FALSE;
+ RETVAL->recno_or_queue = (RETVAL->type == DB_RECNO ||
+ RETVAL->type == DB_QUEUE) ;
+ RETVAL->filename = my_strdup(file) ;
+ RETVAL->Status = Status ;
+ RETVAL->active = TRUE ;
+ hash_store_iv("BerkeleyDB::Term::Db", (char *)RETVAL, 1) ;
+ Trace((" storing %p %p in BerkeleyDB::Term::Db\n", RETVAL, dbp)) ;
+ if (dbenv) {
+ RETVAL->cds_enabled = dbenv->cds_enabled ;
+ RETVAL->parent_env = dbenv ;
+ dbenv->Status = Status ;
+ ++ dbenv->open_dbs ;
+ }
+ }
+ else {
+#if DB_VERSION_MAJOR > 2
+ (dbp->close)(dbp, 0) ;
+#endif
+ destroyDB(db) ;
+ Trace(("db open returned %s\n", my_db_strerror(Status))) ;
+ }
+
+ Trace(("End of _db_open\n"));
+ return RETVAL ;
+}
+
+
+#include "constants.h"
+
+MODULE = BerkeleyDB PACKAGE = BerkeleyDB PREFIX = env_
+
+INCLUDE: constants.xs
+
+#define env_db_version(maj, min, patch) db_version(&maj, &min, &patch)
+char *
+env_db_version(maj, min, patch)
+ int maj
+ int min
+ int patch
+ PREINIT:
+ dMY_CXT;
+ OUTPUT:
+ RETVAL
+ maj
+ min
+ patch
+
+int has_heap()
+ CODE:
+#ifdef AT_LEAST_DB_5_2
+ RETVAL = __heap_exist() ;
+#else
+ RETVAL = 0 ;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+
+int
+db_value_set(value, which)
+ int value
+ int which
+ NOT_IMPLEMENTED_YET
+
+
+DualType
+_db_remove(ref)
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#if DB_VERSION_MAJOR == 2
+ softCrash("BerkeleyDB::db_remove needs Berkeley DB 3.x or better") ;
+#else
+ HV * hash ;
+ DB * dbp ;
+ SV * sv ;
+ const char * db = NULL ;
+ const char * subdb = NULL ;
+ BerkeleyDB__Env env = NULL ;
+ BerkeleyDB__Txn txn = NULL ;
+ DB_ENV * dbenv = NULL ;
+ u_int32_t flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(db, "Filename", char *) ;
+ SetValue_pv(subdb, "Subname", char *) ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_ov(env, "Env", BerkeleyDB__Env) ;
+ if (txn) {
+#ifdef AT_LEAST_DB_4_1
+ if (!env)
+ softCrash("transactional db_remove requires an environment");
+ RETVAL = env->Status = env->Env->dbremove(env->Env, txn->txn, db, subdb, flags);
+#else
+ softCrash("transactional db_remove requires Berkeley DB 4.1 or better");
+#endif
+ } else {
+ if (env)
+ dbenv = env->Env ;
+ RETVAL = db_create(&dbp, dbenv, 0) ;
+ if (RETVAL == 0) {
+ RETVAL = dbp->remove(dbp, db, subdb, flags) ;
+ }
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+DualType
+_db_verify(ref)
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_3_1
+ softCrash("BerkeleyDB::db_verify needs Berkeley DB 3.1.x or better") ;
+#else
+ HV * hash ;
+ DB * dbp ;
+ SV * sv ;
+ const char * db = NULL ;
+ const char * subdb = NULL ;
+ const char * outfile = NULL ;
+ FILE * ofh = NULL;
+ BerkeleyDB__Env env = NULL ;
+ DB_ENV * dbenv = NULL ;
+ u_int32_t flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(db, "Filename", char *) ;
+ SetValue_pv(subdb, "Subname", char *) ;
+ SetValue_pv(outfile, "Outfile", char *) ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_ov(env, "Env", BerkeleyDB__Env) ;
+ RETVAL = 0;
+ if (outfile){
+ ofh = fopen(outfile, "w");
+ if (! ofh)
+ RETVAL = errno;
+ }
+ if (! RETVAL) {
+ if (env)
+ dbenv = env->Env ;
+ RETVAL = db_create(&dbp, dbenv, 0) ;
+ if (RETVAL == 0) {
+ RETVAL = dbp->verify(dbp, db, subdb, ofh, flags) ;
+ }
+ if (outfile)
+ fclose(ofh);
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+DualType
+_db_rename(ref)
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_3_1
+ softCrash("BerkeleyDB::db_rename needs Berkeley DB 3.1.x or better") ;
+#else
+ HV * hash ;
+ DB * dbp ;
+ SV * sv ;
+ const char * db = NULL ;
+ const char * subdb = NULL ;
+ const char * newname = NULL ;
+ BerkeleyDB__Env env = NULL ;
+ BerkeleyDB__Txn txn = NULL ;
+ DB_ENV * dbenv = NULL ;
+ u_int32_t flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(db, "Filename", char *) ;
+ SetValue_pv(subdb, "Subname", char *) ;
+ SetValue_pv(newname, "Newname", char *) ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_ov(env, "Env", BerkeleyDB__Env) ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ if (txn) {
+#ifdef AT_LEAST_DB_4_1
+ if (!env)
+ softCrash("transactional db_rename requires an environment");
+ RETVAL = env->Status = env->Env->dbrename(env->Env, txn->txn, db, subdb, newname, flags);
+#else
+ softCrash("transactional db_rename requires Berkeley DB 4.1 or better");
+#endif
+ } else {
+ if (env)
+ dbenv = env->Env ;
+ RETVAL = db_create(&dbp, dbenv, 0) ;
+ if (RETVAL == 0) {
+ RETVAL = (dbp->rename)(dbp, db, subdb, newname, flags) ;
+ }
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+MODULE = BerkeleyDB::Env PACKAGE = BerkeleyDB::Env PREFIX = env_
+
+BerkeleyDB::Env::Raw
+create(flags=0)
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_4_1
+ softCrash("$env->create needs Berkeley DB 4.1 or better") ;
+#else
+ DB_ENV * env ;
+ int status;
+ RETVAL = NULL;
+ Trace(("in BerkeleyDB::Env::create flags=%d\n", flags)) ;
+ status = db_env_create(&env, flags) ;
+ Trace(("db_env_create returned %s\n", my_db_strerror(status))) ;
+ if (status == 0) {
+ ZMALLOC(RETVAL, BerkeleyDB_ENV_type) ;
+ RETVAL->Env = env ;
+ RETVAL->active = TRUE ;
+ RETVAL->opened = FALSE;
+ env->set_alloc(env, safemalloc, MyRealloc, safefree) ;
+ env->set_errcall(env, db_errcall_cb) ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+int
+open(env, db_home=NULL, flags=0, mode=0777)
+ BerkeleyDB::Env env
+ char * db_home
+ u_int32_t flags
+ int mode
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_4_1
+ softCrash("$env->create needs Berkeley DB 4.1 or better") ;
+#else
+ RETVAL = env->Env->open(env->Env, db_home, flags, mode);
+ env->opened = TRUE;
+#endif
+ OUTPUT:
+ RETVAL
+
+bool
+cds_enabled(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = env->cds_enabled ;
+ OUTPUT:
+ RETVAL
+
+
+int
+set_encrypt(env, passwd, flags)
+ BerkeleyDB::Env env
+ const char * passwd
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_4_1
+ softCrash("$env->set_encrypt needs Berkeley DB 4.1 or better") ;
+#else
+ dieIfEnvOpened(env, "set_encrypt");
+ RETVAL = env->Env->set_encrypt(env->Env, passwd, flags);
+ env->opened = TRUE;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+
+
+BerkeleyDB::Env::Raw
+_db_appinit(self, ref, errfile=NULL)
+ char * self
+ SV * ref
+ SV * errfile
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ HV * hash ;
+ SV * sv ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+ char * home = NULL ;
+ char * server = NULL ;
+ char ** config = NULL ;
+ int flags = 0 ;
+ int setflags = 0 ;
+ int cachesize = 0 ;
+ int lk_detect = 0 ;
+ int tx_max = 0 ;
+ int log_config = 0 ;
+ int max_lockers = 0 ;
+ int max_locks = 0 ;
+ int max_objects = 0 ;
+ long shm_key = 0 ;
+ char* data_dir = 0;
+ char* log_dir = 0;
+ char* temp_dir = 0;
+ SV * msgfile = NULL ;
+ int thread_count = 0 ;
+ SV * errprefix = NULL;
+ DB_ENV * env ;
+ int status ;
+
+ Trace(("in _db_appinit [%s] %d\n", self, ref)) ;
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(home, "Home", char *) ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+ SetValue_pv(config, "Config", char **) ;
+ SetValue_sv(errprefix, "ErrPrefix") ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(setflags, "SetFlags") ;
+ SetValue_pv(server, "Server", char *) ;
+ SetValue_iv(cachesize, "Cachesize") ;
+ SetValue_iv(lk_detect, "LockDetect") ;
+ SetValue_iv(tx_max, "TxMax") ;
+ SetValue_iv(log_config,"LogConfig") ;
+ SetValue_iv(max_lockers,"MaxLockers") ;
+ SetValue_iv(max_locks, "MaxLocks") ;
+ SetValue_iv(max_objects,"MaxObjects") ;
+ SetValue_iv(shm_key, "SharedMemKey") ;
+ SetValue_iv(thread_count, "ThreadCount") ;
+ SetValue_pv(data_dir, "DB_DATA_DIR", char*) ;
+ SetValue_pv(temp_dir, "DB_TEMP_DIR", char*) ;
+ SetValue_pv(log_dir, "DB_LOG_DIR", char*) ;
+ SetValue_sv(msgfile, "MsgFile") ;
+#ifndef AT_LEAST_DB_3_2
+ if (setflags)
+ softCrash("-SetFlags needs Berkeley DB 3.x or better") ;
+#endif /* ! AT_LEAST_DB_3 */
+#ifndef AT_LEAST_DB_3_1
+ if (shm_key)
+ softCrash("-SharedMemKey needs Berkeley DB 3.1 or better") ;
+#endif /* ! AT_LEAST_DB_3_1 */
+#if ! defined(AT_LEAST_DB_3_1) || defined(AT_LEAST_DB_5_1)
+ if (server)
+ softCrash("-Server only supported Berkeley DB 3.1 to 5.1") ;
+#endif /* ! AT_LEAST_DB_3_1 */
+#ifndef AT_LEAST_DB_3_2
+ if (max_lockers)
+ softCrash("-MaxLockers needs Berkeley DB 3.2 or better") ;
+ if (max_locks)
+ softCrash("-MaxLocks needs Berkeley DB 3.2 or better") ;
+ if (max_objects)
+ softCrash("-MaxObjects needs Berkeley DB 3.2 or better") ;
+#endif /* ! AT_LEAST_DB_3_2 */
+#ifndef AT_LEAST_DB_4_1
+ if (enc_passwd)
+ softCrash("-Encrypt needs Berkeley DB 4.x or better") ;
+#endif /* ! AT_LEAST_DB_4_1 */
+#ifndef AT_LEAST_DB_4_3
+ if (msgfile)
+ softCrash("-MsgFile needs Berkeley DB 4.3.x or better") ;
+#endif /* ! AT_LEAST_DB_4_3 */
+#ifdef _WIN32
+ if (thread_count)
+ softCrash("-ThreadCount not supported on Windows") ;
+#endif /* ! _WIN32 */
+#ifndef AT_LEAST_DB_4_4
+ if (thread_count)
+ softCrash("-ThreadCount needs Berkeley DB 4.4 or better") ;
+#endif /* ! AT_LEAST_DB_4_4 */
+#ifndef AT_LEAST_DB_4_7
+ if (log_config)
+ softCrash("-LogConfig needs Berkeley DB 4.7 or better") ;
+#endif /* ! AT_LEAST_DB_4_7 */
+ Trace(("_db_appinit(config=[%d], home=[%s],errprefix=[%s],flags=[%d]\n",
+ config, home, errprefix, flags)) ;
+#ifdef TRACE
+ if (config) {
+ int i ;
+ for (i = 0 ; i < 10 ; ++ i) {
+ if (config[i] == NULL) {
+ printf(" End\n") ;
+ break ;
+ }
+ printf(" config = [%s]\n", config[i]) ;
+ }
+ }
+#endif /* TRACE */
+ ZMALLOC(RETVAL, BerkeleyDB_ENV_type) ;
+ if (flags & DB_INIT_TXN)
+ RETVAL->txn_enabled = TRUE ;
+#if DB_VERSION_MAJOR == 2
+ ZMALLOC(RETVAL->Env, DB_ENV) ;
+ env = RETVAL->Env ;
+ {
+ /* Take a copy of the error prefix */
+ if (errprefix) {
+ Trace(("copying errprefix\n" )) ;
+ RETVAL->ErrPrefix = newSVsv(errprefix) ;
+ SvPOK_only(RETVAL->ErrPrefix) ;
+ }
+ if (RETVAL->ErrPrefix)
+ RETVAL->Env->db_errpfx = SvPVX(RETVAL->ErrPrefix) ;
+
+ if (SvGMAGICAL(errfile))
+ mg_get(errfile);
+ if (SvOK(errfile)) {
+ FILE * ef = GetFILEptr(errfile) ;
+ if (! ef)
+ croak("Cannot open file ErrFile", Strerror(errno));
+ RETVAL->ErrHandle = newSVsv(errfile) ;
+ env->db_errfile = ef;
+ }
+ SetValue_iv(env->db_verbose, "Verbose") ;
+ env->db_errcall = db_errcall_cb ;
+ RETVAL->active = TRUE ;
+ RETVAL->opened = TRUE;
+ RETVAL->cds_enabled = ((flags & DB_INIT_CDB) != 0 ? TRUE : FALSE) ;
+ status = db_appinit(home, config, env, flags) ;
+ printf(" status = %d errno %d \n", status, errno) ;
+ Trace((" status = %d env %d Env %d\n", status, RETVAL, env)) ;
+ if (status == 0)
+ hash_store_iv("BerkeleyDB::Term::Env", (char *)RETVAL, 1) ;
+ else {
+
+ if (RETVAL->ErrHandle)
+ SvREFCNT_dec(RETVAL->ErrHandle) ;
+ if (RETVAL->ErrPrefix)
+ SvREFCNT_dec(RETVAL->ErrPrefix) ;
+ Safefree(RETVAL->Env) ;
+ Safefree(RETVAL) ;
+ RETVAL = NULL ;
+ }
+ }
+#else /* DB_VERSION_MAJOR > 2 */
+#ifndef AT_LEAST_DB_3_1
+# define DB_CLIENT 0
+#endif
+#ifdef AT_LEAST_DB_5_1
+# define DB_CLIENT 0
+#else
+# ifdef AT_LEAST_DB_4_2
+# define DB_CLIENT DB_RPCCLIENT
+# endif
+#endif
+ status = db_env_create(&RETVAL->Env, server ? DB_CLIENT : 0) ;
+ Trace(("db_env_create flags = %d returned %s\n", flags,
+ my_db_strerror(status))) ;
+ env = RETVAL->Env ;
+#ifdef AT_LEAST_DB_3_3
+ env->set_alloc(env, safemalloc, MyRealloc, safefree) ;
+#endif
+#ifdef AT_LEAST_DB_3_1
+ if (status == 0 && shm_key) {
+ status = env->set_shm_key(env, shm_key) ;
+ Trace(("set_shm_key [%d] returned %s\n", shm_key,
+ my_db_strerror(status)));
+ }
+
+ if (status == 0 && data_dir) {
+ status = env->set_data_dir(env, data_dir) ;
+ Trace(("set_data_dir [%s] returned %s\n", data_dir,
+ my_db_strerror(status)));
+ }
+
+ if (status == 0 && temp_dir) {
+ status = env->set_tmp_dir(env, temp_dir) ;
+ Trace(("set_tmp_dir [%s] returned %s\n", temp_dir,
+ my_db_strerror(status)));
+ }
+
+ if (status == 0 && log_dir) {
+ status = env->set_lg_dir(env, log_dir) ;
+ Trace(("set_lg_dir [%s] returned %s\n", log_dir,
+ my_db_strerror(status)));
+ }
+#endif
+ if (status == 0 && cachesize) {
+ status = env->set_cachesize(env, 0, cachesize, 0) ;
+ Trace(("set_cachesize [%d] returned %s\n",
+ cachesize, my_db_strerror(status)));
+ }
+
+ if (status == 0 && lk_detect) {
+ status = env->set_lk_detect(env, lk_detect) ;
+ Trace(("set_lk_detect [%d] returned %s\n",
+ lk_detect, my_db_strerror(status)));
+ }
+
+ if (status == 0 && tx_max) {
+ status = env->set_tx_max(env, tx_max) ;
+ Trace(("set_tx_max [%d] returned %s\n",
+ tx_max, my_db_strerror(status)));
+ }
+#ifdef AT_LEAST_DB_4_7
+ if (status == 0 && log_config) {
+ status = env->log_set_config(env, log_config, 1) ;
+ Trace(("log_set_config [%d] returned %s\n",
+ log_config, my_db_strerror(status)));
+ }
+#endif /* AT_LEAST_DB_4_7 */
+#ifdef AT_LEAST_DB_3_2
+ if (status == 0 && max_lockers) {
+ status = env->set_lk_max_lockers(env, max_lockers) ;
+ Trace(("set_lk_max_lockers [%d] returned %s\n",
+ max_lockers, my_db_strerror(status)));
+ }
+
+ if (status == 0 && max_locks) {
+ status = env->set_lk_max_locks(env, max_locks) ;
+ Trace(("set_lk_max_locks [%d] returned %s\n",
+ max_locks, my_db_strerror(status)));
+ }
+
+ if (status == 0 && max_objects) {
+ status = env->set_lk_max_objects(env, max_objects) ;
+ Trace(("set_lk_max_objects [%d] returned %s\n",
+ max_objects, my_db_strerror(status)));
+ }
+#endif /* AT_LEAST_DB_3_2 */
+#ifdef AT_LEAST_DB_4_1
+ /* set encryption */
+ if (enc_passwd && status == 0)
+ {
+ status = env->set_encrypt(env, enc_passwd, enc_flags);
+ Trace(("ENV->set_encrypt passwd = %s, flags %d returned %s\n",
+ enc_passwd, enc_flags,
+ my_db_strerror(status))) ;
+ }
+#endif
+#if ! defined(AT_LEAST_DB_5_1)
+#ifdef AT_LEAST_DB_4
+ /* set the server */
+ if (server && status == 0)
+ {
+ status = env->set_rpc_server(env, NULL, server, 0, 0, 0);
+ Trace(("ENV->set_rpc_server server = %s returned %s\n", server,
+ my_db_strerror(status))) ;
+ }
+#else
+# if defined(AT_LEAST_DB_3_1) && ! defined(AT_LEAST_DB_4)
+ /* set the server */
+ if (server && status == 0)
+ {
+ status = env->set_server(env, server, 0, 0, 0);
+ Trace(("ENV->set_server server = %s returned %s\n", server,
+ my_db_strerror(status))) ;
+ }
+# endif
+#endif
+#endif
+#ifdef AT_LEAST_DB_3_2
+ if (setflags && status == 0)
+ {
+ status = env->set_flags(env, setflags, 1);
+ Trace(("ENV->set_flags value = %d returned %s\n", setflags,
+ my_db_strerror(status))) ;
+ }
+#endif
+#if defined(AT_LEAST_DB_4_4) && ! defined(_WIN32)
+ if (thread_count && status == 0)
+ {
+ status = env->set_thread_count(env, thread_count);
+ Trace(("ENV->set_thread_count value = %d returned %s\n", thread_count,
+ my_db_strerror(status))) ;
+ }
+#endif
+
+ if (status == 0)
+ {
+ int mode = 0 ;
+ /* Take a copy of the error prefix */
+ if (errprefix) {
+ Trace(("copying errprefix\n" )) ;
+ RETVAL->ErrPrefix = newSVsv(errprefix) ;
+ SvPOK_only(RETVAL->ErrPrefix) ;
+ }
+ if (RETVAL->ErrPrefix)
+ env->set_errpfx(env, SvPVX(RETVAL->ErrPrefix)) ;
+
+ if (SvGMAGICAL(errfile))
+ mg_get(errfile);
+ if (SvOK(errfile)) {
+ FILE * ef = GetFILEptr(errfile);
+ if (! ef)
+ croak("Cannot open file ErrFile", Strerror(errno));
+ RETVAL->ErrHandle = newSVsv(errfile) ;
+ env->set_errfile(env, ef) ;
+
+ }
+#ifdef AT_LEAST_DB_4_3
+ if (msgfile) {
+ if (SvGMAGICAL(msgfile))
+ mg_get(msgfile);
+ if (SvOK(msgfile)) {
+ FILE * ef = GetFILEptr(msgfile);
+ if (! ef)
+ croak("Cannot open file MsgFile", Strerror(errno));
+ RETVAL->MsgHandle = newSVsv(msgfile) ;
+ env->set_msgfile(env, ef) ;
+ }
+ }
+#endif
+ SetValue_iv(mode, "Mode") ;
+ env->set_errcall(env, db_errcall_cb) ;
+ RETVAL->active = TRUE ;
+ RETVAL->cds_enabled = ((flags & DB_INIT_CDB) != 0 ? TRUE : FALSE) ;
+#ifdef IS_DB_3_0_x
+ status = (env->open)(env, home, config, flags, mode) ;
+#else /* > 3.0 */
+ status = (env->open)(env, home, flags, mode) ;
+#endif
+ Trace(("ENV->open(env=%s,home=%s,flags=%d,mode=%d)\n",env,home,flags,mode)) ;
+ Trace(("ENV->open returned %s\n", my_db_strerror(status))) ;
+ }
+
+ if (status == 0)
+ hash_store_iv("BerkeleyDB::Term::Env", (char *)RETVAL, 1) ;
+ else {
+ (env->close)(env, 0) ;
+#ifdef AT_LEAST_DB_4_3
+ if (RETVAL->MsgHandle)
+ SvREFCNT_dec(RETVAL->MsgHandle) ;
+#endif
+ if (RETVAL->ErrHandle)
+ SvREFCNT_dec(RETVAL->ErrHandle) ;
+ if (RETVAL->ErrPrefix)
+ SvREFCNT_dec(RETVAL->ErrPrefix) ;
+ Safefree(RETVAL) ;
+ RETVAL = NULL ;
+ }
+#endif /* DB_VERSION_MAJOR > 2 */
+ {
+ SV * sv_err = perl_get_sv(ERR_BUFF, FALSE);
+ sv_setpv(sv_err, db_strerror(status));
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+DB_ENV*
+DB_ENV(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ if (env->active)
+ RETVAL = env->Env ;
+ else
+ RETVAL = NULL;
+ OUTPUT:
+ RETVAL
+
+
+void
+log_archive(env, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ PPCODE:
+ {
+ char ** list;
+ char ** file;
+ AV * av;
+#ifndef AT_LEAST_DB_3
+ softCrash("log_archive needs at least Berkeley DB 3.x.x");
+#else
+# ifdef AT_LEAST_DB_4
+ env->Status = env->Env->log_archive(env->Env, &list, flags) ;
+# else
+# ifdef AT_LEAST_DB_3_3
+ env->Status = log_archive(env->Env, &list, flags) ;
+# else
+ env->Status = log_archive(env->Env, &list, flags, safemalloc) ;
+# endif
+# endif
+#ifdef DB_ARCH_REMOVE
+ if (env->Status == 0 && list != NULL && flags != DB_ARCH_REMOVE)
+#else
+ if (env->Status == 0 && list != NULL )
+#endif
+ {
+ for (file = list; *file != NULL; ++file)
+ {
+ XPUSHs(sv_2mortal(newSVpv(*file, 0))) ;
+ }
+ safefree(list);
+ }
+#endif
+ }
+
+DualType
+log_set_config(env, flags=0, onoff=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ int onoff
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_4_7
+ softCrash("log_set_config needs at least Berkeley DB 4.7.x");
+#else
+ RETVAL = env->Status = env->Env->log_set_config(env->Env, flags, onoff) ;
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+DualType
+log_get_config(env, flags, onoff)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ int onoff=NO_INIT
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_4_7
+ softCrash("log_get_config needs at least Berkeley DB 4.7.x");
+#else
+ RETVAL = env->Status = env->Env->log_get_config(env->Env, flags, &onoff) ;
+#endif
+ }
+ OUTPUT:
+ RETVAL
+ onoff
+
+
+BerkeleyDB::Txn::Raw
+_txn_begin(env, pid=NULL, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Env env
+ BerkeleyDB::Txn pid
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DB_TXN *txn ;
+ DB_TXN *p_id = NULL ;
+ Trace(("txn_begin pid %d, flags %d\n", pid, flags)) ;
+#if DB_VERSION_MAJOR == 2
+ if (env->Env->tx_info == NULL)
+ softCrash("Transaction Manager not enabled") ;
+#endif
+ if (!env->txn_enabled)
+ softCrash("Transaction Manager not enabled") ;
+ if (pid)
+ p_id = pid->txn ;
+ env->TxnMgrStatus =
+#if DB_VERSION_MAJOR == 2
+ txn_begin(env->Env->tx_info, p_id, &txn) ;
+#else
+# ifdef AT_LEAST_DB_4
+ env->Env->txn_begin(env->Env, p_id, &txn, flags) ;
+# else
+ txn_begin(env->Env, p_id, &txn, flags) ;
+# endif
+#endif
+ if (env->TxnMgrStatus == 0) {
+ ZMALLOC(RETVAL, BerkeleyDB_Txn_type) ;
+ RETVAL->txn = txn ;
+ RETVAL->active = TRUE ;
+ Trace(("_txn_begin created txn [%p] in [%p]\n", txn, RETVAL));
+ hash_store_iv("BerkeleyDB::Term::Txn", (char *)RETVAL, 1) ;
+ }
+ else
+ RETVAL = NULL ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+#if DB_VERSION_MAJOR == 2
+# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env->tx_info, k, m)
+#else /* DB 3.0 or better */
+# ifdef AT_LEAST_DB_4
+# define env_txn_checkpoint(e,k,m,f) e->Env->txn_checkpoint(e->Env, k, m, f)
+# else
+# ifdef AT_LEAST_DB_3_1
+# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env, k, m, 0)
+# else
+# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env, k, m)
+# endif
+# endif
+#endif
+DualType
+env_txn_checkpoint(env, kbyte, min, flags=0)
+ BerkeleyDB::Env env
+ long kbyte
+ long min
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+
+HV *
+txn_stat(env)
+ BerkeleyDB::Env env
+ HV * RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DB_TXN_STAT * stat ;
+#ifdef AT_LEAST_DB_4
+ if(env->Env->txn_stat(env->Env, &stat, 0) == 0) {
+#else
+# ifdef AT_LEAST_DB_3_3
+ if(txn_stat(env->Env, &stat) == 0) {
+# else
+# if DB_VERSION_MAJOR == 2
+ if(txn_stat(env->Env->tx_info, &stat, safemalloc) == 0) {
+# else
+ if(txn_stat(env->Env, &stat, safemalloc) == 0) {
+# endif
+# endif
+#endif
+ RETVAL = (HV*)sv_2mortal((SV*)newHV()) ;
+ hv_store_iv(RETVAL, "st_time_ckp", stat->st_time_ckp) ;
+ hv_store_iv(RETVAL, "st_last_txnid", stat->st_last_txnid) ;
+ hv_store_iv(RETVAL, "st_maxtxns", stat->st_maxtxns) ;
+ hv_store_iv(RETVAL, "st_naborts", stat->st_naborts) ;
+ hv_store_iv(RETVAL, "st_nbegins", stat->st_nbegins) ;
+ hv_store_iv(RETVAL, "st_ncommits", stat->st_ncommits) ;
+ hv_store_iv(RETVAL, "st_nactive", stat->st_nactive) ;
+#if DB_VERSION_MAJOR > 2
+ hv_store_iv(RETVAL, "st_maxnactive", stat->st_maxnactive) ;
+ hv_store_iv(RETVAL, "st_regsize", stat->st_regsize) ;
+ hv_store_iv(RETVAL, "st_region_wait", stat->st_region_wait) ;
+ hv_store_iv(RETVAL, "st_region_nowait", stat->st_region_nowait) ;
+#endif
+ safefree(stat) ;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+#define EnDis(x) ((x) ? "Enabled" : "Disabled")
+void
+printEnv(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Environment(env->active) ;
+ CODE:
+#if 0
+ printf("env [0x%X]\n", env) ;
+ printf(" ErrPrefix [%s]\n", env->ErrPrefix
+ ? SvPVX(env->ErrPrefix) : 0) ;
+ printf(" DB_ENV\n") ;
+ printf(" db_lorder [%d]\n", env->Env.db_lorder) ;
+ printf(" db_home [%s]\n", env->Env.db_home) ;
+ printf(" db_data_dir [%s]\n", env->Env.db_data_dir) ;
+ printf(" db_log_dir [%s]\n", env->Env.db_log_dir) ;
+ printf(" db_tmp_dir [%s]\n", env->Env.db_tmp_dir) ;
+ printf(" lk_info [%s]\n", EnDis(env->Env.lk_info)) ;
+ printf(" lk_max [%d]\n", env->Env.lk_max) ;
+ printf(" lg_info [%s]\n", EnDis(env->Env.lg_info)) ;
+ printf(" lg_max [%d]\n", env->Env.lg_max) ;
+ printf(" mp_info [%s]\n", EnDis(env->Env.mp_info)) ;
+ printf(" mp_size [%d]\n", env->Env.mp_size) ;
+ printf(" tx_info [%s]\n", EnDis(env->Env.tx_info)) ;
+ printf(" tx_max [%d]\n", env->Env.tx_max) ;
+ printf(" flags [%d]\n", env->Env.flags) ;
+ printf("\n") ;
+#endif
+
+SV *
+errPrefix(env, prefix)
+ BerkeleyDB::Env env
+ SV * prefix
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Environment(env->active) ;
+ CODE:
+ if (env->ErrPrefix) {
+ RETVAL = newSVsv(env->ErrPrefix) ;
+ SvPOK_only(RETVAL) ;
+ sv_setsv(env->ErrPrefix, prefix) ;
+ }
+ else {
+ RETVAL = NULL ;
+ env->ErrPrefix = newSVsv(prefix) ;
+ }
+ SvPOK_only(env->ErrPrefix) ;
+#if DB_VERSION_MAJOR == 2
+ env->Env->db_errpfx = SvPVX(env->ErrPrefix) ;
+#else
+ env->Env->set_errpfx(env->Env, SvPVX(env->ErrPrefix)) ;
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+status(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = env->Status ;
+ OUTPUT:
+ RETVAL
+
+
+
+DualType
+db_appexit(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ ALIAS: close =1
+ INIT:
+ ckActive_Environment(env->active) ;
+ CODE:
+#ifdef STRICT_CLOSE
+ if (env->open_dbs)
+ softCrash("attempted to close an environment with %d open database(s)",
+ env->open_dbs) ;
+#endif /* STRICT_CLOSE */
+#if DB_VERSION_MAJOR == 2
+ RETVAL = db_appexit(env->Env) ;
+#else
+ RETVAL = (env->Env->close)(env->Env, 0) ;
+#endif
+ env->active = FALSE ;
+ hash_delete("BerkeleyDB::Term::Env", (char *)env) ;
+ OUTPUT:
+ RETVAL
+
+
+void
+_DESTROY(env)
+ BerkeleyDB::Env env
+ int RETVAL = 0 ;
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ Trace(("In BerkeleyDB::Env::DESTROY\n"));
+ Trace((" env %ld Env %ld dirty %d\n", env, &env->Env, PL_dirty)) ;
+ if (env->active)
+#if DB_VERSION_MAJOR == 2
+ db_appexit(env->Env) ;
+#else
+ (env->Env->close)(env->Env, 0) ;
+#endif
+ if (env->ErrHandle)
+ SvREFCNT_dec(env->ErrHandle) ;
+#ifdef AT_LEAST_DB_4_3
+ if (env->MsgHandle)
+ SvREFCNT_dec(env->MsgHandle) ;
+#endif
+ if (env->ErrPrefix)
+ SvREFCNT_dec(env->ErrPrefix) ;
+#if DB_VERSION_MAJOR == 2
+ Safefree(env->Env) ;
+#endif
+ Safefree(env) ;
+ hash_delete("BerkeleyDB::Term::Env", (char *)env) ;
+ Trace(("End of BerkeleyDB::Env::DESTROY %d\n", RETVAL)) ;
+
+BerkeleyDB::TxnMgr::Raw
+_TxnMgr(env)
+ BerkeleyDB::Env env
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Environment(env->active) ;
+ if (!env->txn_enabled)
+ softCrash("Transaction Manager not enabled") ;
+ CODE:
+ ZMALLOC(RETVAL, BerkeleyDB_TxnMgr_type) ;
+ RETVAL->env = env ;
+ /* hash_store_iv("BerkeleyDB::Term::TxnMgr", (char *)txn, 1) ; */
+ OUTPUT:
+ RETVAL
+
+int
+get_shm_key(env, id)
+ BerkeleyDB::Env env
+ long id = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_2
+ softCrash("$env->get_shm_key needs Berkeley DB 4.2 or better") ;
+#else
+ RETVAL = env->Env->get_shm_key(env->Env, &id);
+#endif
+ OUTPUT:
+ RETVAL
+ id
+
+
+int
+set_lg_dir(env, dir)
+ BerkeleyDB::Env env
+ char * dir
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_1
+ softCrash("$env->set_lg_dir needs Berkeley DB 3.1 or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_lg_dir(env->Env, dir);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_lg_bsize(env, bsize)
+ BerkeleyDB::Env env
+ u_int32_t bsize
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3
+ softCrash("$env->set_lg_bsize needs Berkeley DB 3.0.55 or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_lg_bsize(env->Env, bsize);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_lg_max(env, lg_max)
+ BerkeleyDB::Env env
+ u_int32_t lg_max
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3
+ softCrash("$env->set_lg_max needs Berkeley DB 3.0.55 or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_lg_max(env->Env, lg_max);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_data_dir(env, dir)
+ BerkeleyDB::Env env
+ char * dir
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_1
+ softCrash("$env->set_data_dir needs Berkeley DB 3.1 or better") ;
+#else
+ dieIfEnvOpened(env, "set_data_dir");
+ RETVAL = env->Status = env->Env->set_data_dir(env->Env, dir);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_tmp_dir(env, dir)
+ BerkeleyDB::Env env
+ char * dir
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_1
+ softCrash("$env->set_tmp_dir needs Berkeley DB 3.1 or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_tmp_dir(env->Env, dir);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_mutexlocks(env, do_lock)
+ BerkeleyDB::Env env
+ int do_lock
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3
+ softCrash("$env->set_setmutexlocks needs Berkeley DB 3.0 or better") ;
+#else
+# ifdef AT_LEAST_DB_4
+ RETVAL = env->Status = env->Env->set_flags(env->Env, DB_NOLOCKING, !do_lock);
+# else
+# if defined(AT_LEAST_DB_3_2_6) || defined(IS_DB_3_0_x)
+ RETVAL = env->Status = env->Env->set_mutexlocks(env->Env, do_lock);
+# else /* DB 3.1 or 3.2.3 */
+ RETVAL = env->Status = db_env_set_mutexlocks(do_lock);
+# endif
+# endif
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_verbose(env, which, onoff)
+ BerkeleyDB::Env env
+ u_int32_t which
+ int onoff
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3
+ softCrash("$env->set_verbose needs Berkeley DB 3.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_verbose(env->Env, which, onoff);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_flags(env, flags, onoff)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ int onoff
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_2
+ softCrash("$env->set_flags needs Berkeley DB 3.2.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_flags(env->Env, flags, onoff);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+lsn_reset(env, file, flags)
+ BerkeleyDB::Env env
+ char* file
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$env->lsn_reset needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->lsn_reset(env->Env, file, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+lock_detect(env, atype=DB_LOCK_DEFAULT, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t atype
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_2_2
+ softCrash("$env->lock_detect needs Berkeley DB 2.2.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->lock_detect(env->Env,flags,atype,NULL);
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+set_timeout(env, timeout, flags=0)
+ BerkeleyDB::Env env
+ db_timeout_t timeout
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4
+ softCrash("$env->set_timeout needs Berkeley DB 4.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->set_timeout(env->Env, timeout, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+get_timeout(env, timeout, flags=0)
+ BerkeleyDB::Env env
+ db_timeout_t timeout = NO_INIT
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_2
+ softCrash("$env->set_timeout needs Berkeley DB 4.2.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->get_timeout(env->Env, &timeout, flags);
+#endif
+ OUTPUT:
+ RETVAL
+ timeout
+
+int
+stat_print(env, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$env->stat_print needs Berkeley DB 4.3 or better") ;
+#else
+ RETVAL = env->Status = env->Env->stat_print(env->Env, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+lock_stat_print(env, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$env->lock_stat_print needs Berkeley DB 4.3 or better") ;
+#else
+ RETVAL = env->Status = env->Env->lock_stat_print(env->Env, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+mutex_stat_print(env, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_4
+ softCrash("$env->mutex_stat_print needs Berkeley DB 4.4 or better") ;
+#else
+ RETVAL = env->Status = env->Env->mutex_stat_print(env->Env, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+txn_stat_print(env, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$env->mutex_stat_print needs Berkeley DB 4.3 or better") ;
+#else
+ RETVAL = env->Status = env->Env->txn_stat_print(env->Env, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+failchk(env, flags=0)
+ BerkeleyDB::Env env
+ u_int32_t flags
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#if ! defined(AT_LEAST_DB_4_4) || defined(_WIN32)
+#ifndef AT_LEAST_DB_4_4
+ softCrash("$env->failchk needs Berkeley DB 4.4 or better") ;
+#endif
+#ifdef _WIN32
+ softCrash("$env->failchk not supported on Windows") ;
+#endif
+#else
+ RETVAL = env->Status = env->Env->failchk(env->Env, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_isalive(env)
+ BerkeleyDB::Env env
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#if ! defined(AT_LEAST_DB_4_4) || defined(_WIN32)
+#ifndef AT_LEAST_DB_4_4
+ softCrash("$env->set_isalive needs Berkeley DB 4.4 or better") ;
+#endif
+#ifdef _WIN32
+ softCrash("$env->set_isalive not supported on Windows") ;
+#endif
+#else
+ RETVAL = env->Status = env->Env->set_isalive(env->Env, db_isalive_cb);
+#endif
+ OUTPUT:
+ RETVAL
+
+
+
+
+MODULE = BerkeleyDB::Term PACKAGE = BerkeleyDB::Term
+
+void
+close_everything()
+ PREINIT:
+ dMY_CXT;
+
+#define safeCroak(string) softCrash(string)
+void
+safeCroak(string)
+ char * string
+ PREINIT:
+ dMY_CXT;
+
+MODULE = BerkeleyDB::Hash PACKAGE = BerkeleyDB::Hash PREFIX = hash_
+
+BerkeleyDB::Hash::Raw
+_db_open_hash(self, ref)
+ char * self
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB__Txn txn = NULL ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ Trace(("_db_open_hash start\n")) ;
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Filename", char *) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.h_ffactor, "Ffactor") ;
+ SetValue_iv(info.h_nelem, "Nelem") ;
+ SetValue_iv(info.flags, "Property") ;
+ ZMALLOC(db, BerkeleyDB_type) ;
+ if ((sv = readHash(hash, "Hash")) && sv != &PL_sv_undef) {
+ info.h_hash = hash_cb ;
+ db->hash = newSVsv(sv) ;
+ }
+ /* DB_DUPSORT was introduced in DB 2.5.9 */
+ if ((sv = readHash(hash, "DupCompare")) && sv != &PL_sv_undef) {
+#ifdef DB_DUPSORT
+ info.dup_compare = dup_compare ;
+ db->dup_compare = newSVsv(sv) ;
+ info.flags |= DB_DUP|DB_DUPSORT ;
+#else
+ croak("DupCompare needs Berkeley DB 2.5.9 or later") ;
+#endif
+ }
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_HASH, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+ Trace(("_db_open_hash end\n")) ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+HV *
+db_stat(db, flags=0)
+ int flags
+ BerkeleyDB::Common db
+ HV * RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+#if DB_VERSION_MAJOR == 2
+ softCrash("$db->db_stat for a Hash needs Berkeley DB 3.x or better") ;
+#else
+ DB_HASH_STAT * stat ;
+#ifdef AT_LEAST_DB_4_3
+ db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
+#else
+#ifdef AT_LEAST_DB_3_3
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
+#else
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ;
+#endif
+#endif
+ if (db->Status) {
+ XSRETURN_UNDEF;
+ } else {
+ RETVAL = (HV*)sv_2mortal((SV*)newHV()) ;
+ hv_store_iv(RETVAL, "hash_magic", stat->hash_magic) ;
+ hv_store_iv(RETVAL, "hash_version", stat->hash_version);
+ hv_store_iv(RETVAL, "hash_pagesize", stat->hash_pagesize);
+#ifdef AT_LEAST_DB_3_1
+ hv_store_iv(RETVAL, "hash_nkeys", stat->hash_nkeys);
+ hv_store_iv(RETVAL, "hash_ndata", stat->hash_ndata);
+#else
+ hv_store_iv(RETVAL, "hash_nrecs", stat->hash_nrecs);
+#endif
+#ifndef AT_LEAST_DB_3_1
+ hv_store_iv(RETVAL, "hash_nelem", stat->hash_nelem);
+#endif
+ hv_store_iv(RETVAL, "hash_ffactor", stat->hash_ffactor);
+ hv_store_iv(RETVAL, "hash_buckets", stat->hash_buckets);
+ hv_store_iv(RETVAL, "hash_free", stat->hash_free);
+ hv_store_iv(RETVAL, "hash_bfree", stat->hash_bfree);
+ hv_store_iv(RETVAL, "hash_bigpages", stat->hash_bigpages);
+ hv_store_iv(RETVAL, "hash_big_bfree", stat->hash_big_bfree);
+ hv_store_iv(RETVAL, "hash_overflows", stat->hash_overflows);
+ hv_store_iv(RETVAL, "hash_ovfl_free", stat->hash_ovfl_free);
+ hv_store_iv(RETVAL, "hash_dup", stat->hash_dup);
+ hv_store_iv(RETVAL, "hash_dup_free", stat->hash_dup_free);
+#if DB_VERSION_MAJOR >= 3
+ hv_store_iv(RETVAL, "hash_metaflags", stat->hash_metaflags);
+#endif
+ safefree(stat) ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+
+MODULE = BerkeleyDB::Unknown PACKAGE = BerkeleyDB::Unknown PREFIX = hash_
+
+void
+_db_open_unknown(ref)
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ PPCODE:
+ {
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB RETVAL ;
+ BerkeleyDB__Txn txn = NULL ;
+#ifdef AT_LEAST_DB_5_2
+ static char * Names[] = {"", "Btree", "Hash", "Recno", "Queue", "Unknown", "Heap"} ;
+#else
+ static char * Names[] = {"", "Btree", "Hash", "Recno", "Queue", "Unknown", "Heap"} ;
+#endif
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Filename", char *) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.h_ffactor, "Ffactor") ;
+ SetValue_iv(info.h_nelem, "Nelem") ;
+ SetValue_iv(info.flags, "Property") ;
+ ZMALLOC(db, BerkeleyDB_type) ;
+
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_UNKNOWN, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+ XPUSHs(sv_2mortal(newSViv(PTR2IV(RETVAL))));
+ if (RETVAL)
+ XPUSHs(sv_2mortal(newSVpv(Names[RETVAL->type], 0))) ;
+ else
+ XPUSHs(sv_2mortal(newSViv((IV)NULL)));
+ }
+
+
+
+MODULE = BerkeleyDB::Btree PACKAGE = BerkeleyDB::Btree PREFIX = btree_
+
+BerkeleyDB::Btree::Raw
+_db_open_btree(self, ref)
+ char * self
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB__Txn txn = NULL ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ Trace(("In _db_open_btree\n"));
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Filename", char*) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.bt_minkey, "Minkey") ;
+ SetValue_iv(info.flags, "Property") ;
+ ZMALLOC(db, BerkeleyDB_type) ;
+ if ((sv = readHash(hash, "Compare")) && sv != &PL_sv_undef) {
+ Trace((" Parsed Compare callback\n"));
+ info.bt_compare = btree_compare ;
+ db->compare = newSVsv(sv) ;
+ }
+ /* DB_DUPSORT was introduced in DB 2.5.9 */
+ if ((sv = readHash(hash, "DupCompare")) && sv != &PL_sv_undef) {
+#ifdef DB_DUPSORT
+ Trace((" Parsed DupCompare callback\n"));
+ info.dup_compare = dup_compare ;
+ db->dup_compare = newSVsv(sv) ;
+ info.flags |= DB_DUP|DB_DUPSORT ;
+#else
+ softCrash("DupCompare needs Berkeley DB 2.5.9 or later") ;
+#endif
+ }
+ if ((sv = readHash(hash, "Prefix")) && sv != &PL_sv_undef) {
+ Trace((" Parsed Prefix callback\n"));
+ info.bt_prefix = btree_prefix ;
+ db->prefix = newSVsv(sv) ;
+ }
+
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_BTREE, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+HV *
+db_stat(db, flags=0)
+ int flags
+ BerkeleyDB::Common db
+ HV * RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+ DB_BTREE_STAT * stat ;
+#ifdef AT_LEAST_DB_4_3
+ db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
+#else
+#ifdef AT_LEAST_DB_3_3
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
+#else
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ;
+#endif
+#endif
+ if (db->Status) {
+ XSRETURN_UNDEF;
+ } else {
+ RETVAL = (HV*)sv_2mortal((SV*)newHV()) ;
+ hv_store_iv(RETVAL, "bt_magic", stat->bt_magic);
+ hv_store_iv(RETVAL, "bt_version", stat->bt_version);
+#if DB_VERSION_MAJOR > 2
+ hv_store_iv(RETVAL, "bt_metaflags", stat->bt_metaflags) ;
+ hv_store_iv(RETVAL, "bt_flags", stat->bt_metaflags) ;
+#else
+ hv_store_iv(RETVAL, "bt_flags", stat->bt_flags) ;
+#endif
+#ifndef AT_LEAST_DB_4_4
+ hv_store_iv(RETVAL, "bt_maxkey", stat->bt_maxkey) ;
+#endif
+ hv_store_iv(RETVAL, "bt_minkey", stat->bt_minkey);
+ hv_store_iv(RETVAL, "bt_re_len", stat->bt_re_len);
+ hv_store_iv(RETVAL, "bt_re_pad", stat->bt_re_pad);
+ hv_store_iv(RETVAL, "bt_pagesize", stat->bt_pagesize);
+ hv_store_iv(RETVAL, "bt_levels", stat->bt_levels);
+#ifdef AT_LEAST_DB_3_1
+ hv_store_iv(RETVAL, "bt_nkeys", stat->bt_nkeys);
+ hv_store_iv(RETVAL, "bt_ndata", stat->bt_ndata);
+#else
+ hv_store_iv(RETVAL, "bt_nrecs", stat->bt_nrecs);
+#endif
+ hv_store_iv(RETVAL, "bt_int_pg", stat->bt_int_pg);
+ hv_store_iv(RETVAL, "bt_leaf_pg", stat->bt_leaf_pg);
+ hv_store_iv(RETVAL, "bt_dup_pg", stat->bt_dup_pg);
+ hv_store_iv(RETVAL, "bt_over_pg", stat->bt_over_pg);
+ hv_store_iv(RETVAL, "bt_free", stat->bt_free);
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+ hv_store_iv(RETVAL, "bt_freed", stat->bt_freed);
+ hv_store_iv(RETVAL, "bt_pfxsaved", stat->bt_pfxsaved);
+ hv_store_iv(RETVAL, "bt_split", stat->bt_split);
+ hv_store_iv(RETVAL, "bt_rootsplit", stat->bt_rootsplit);
+ hv_store_iv(RETVAL, "bt_fastsplit", stat->bt_fastsplit);
+ hv_store_iv(RETVAL, "bt_added", stat->bt_added);
+ hv_store_iv(RETVAL, "bt_deleted", stat->bt_deleted);
+ hv_store_iv(RETVAL, "bt_get", stat->bt_get);
+ hv_store_iv(RETVAL, "bt_cache_hit", stat->bt_cache_hit);
+ hv_store_iv(RETVAL, "bt_cache_miss", stat->bt_cache_miss);
+#endif
+ hv_store_iv(RETVAL, "bt_int_pgfree", stat->bt_int_pgfree);
+ hv_store_iv(RETVAL, "bt_leaf_pgfree", stat->bt_leaf_pgfree);
+ hv_store_iv(RETVAL, "bt_dup_pgfree", stat->bt_dup_pgfree);
+ hv_store_iv(RETVAL, "bt_over_pgfree", stat->bt_over_pgfree);
+ safefree(stat) ;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+MODULE = BerkeleyDB::Heap PACKAGE = BerkeleyDB::Heap PREFIX = heap_
+
+BerkeleyDB::Heap::Raw
+_db_open_heap(self, ref)
+ char * self
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_5_2
+ softCrash("BerkeleyDB::Heap needs Berkeley DB 5.2.x or better");
+#else
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB__Txn txn = NULL ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ Trace(("In _db_open_btree\n"));
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Filename", char*) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.flags, "Property") ;
+ SetValue_iv(info.heapsize_bytes, "HeapSize") ;
+ SetValue_iv(info.heapsize_gbytes, "HeapSizeGb") ;
+ ZMALLOC(db, BerkeleyDB_type) ;
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_HEAP, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+
+
+MODULE = BerkeleyDB::Recno PACKAGE = BerkeleyDB::Recno PREFIX = recno_
+
+BerkeleyDB::Recno::Raw
+_db_open_recno(self, ref)
+ char * self
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB__Txn txn = NULL ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Fname", char*) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.bt_minkey, "Minkey") ;
+
+ SetValue_iv(info.flags, "Property") ;
+ SetValue_pv(info.re_source, "Source", char*) ;
+ if ((sv = readHash(hash, "Len")) && sv != &PL_sv_undef) {
+ info.re_len = SvIV(sv) ; ;
+ flagSet_DB2(info.flags, DB_FIXEDLEN) ;
+ }
+ if ((sv = readHash(hash, "Delim")) && sv != &PL_sv_undef) {
+ info.re_delim = SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ;
+ flagSet_DB2(info.flags, DB_DELIMITER) ;
+ }
+ if ((sv = readHash(hash, "Pad")) && sv != &PL_sv_undef) {
+ info.re_pad = (u_int32_t)SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ;
+ flagSet_DB2(info.flags, DB_PAD) ;
+ }
+ ZMALLOC(db, BerkeleyDB_type) ;
+#ifdef ALLOW_RECNO_OFFSET
+ SetValue_iv(db->array_base, "ArrayBase") ;
+ db->array_base = (db->array_base == 0 ? 1 : 0) ;
+#endif /* ALLOW_RECNO_OFFSET */
+
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_RECNO, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+MODULE = BerkeleyDB::Queue PACKAGE = BerkeleyDB::Queue PREFIX = recno_
+
+BerkeleyDB::Queue::Raw
+_db_open_queue(self, ref)
+ char * self
+ SV * ref
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_3
+ softCrash("BerkeleyDB::Queue needs Berkeley DB 3.0.x or better");
+#else
+ HV * hash ;
+ SV * sv ;
+ DB_INFO info ;
+ BerkeleyDB__Env dbenv = NULL;
+ SV * ref_dbenv = NULL;
+ const char * file = NULL ;
+ const char * subname = NULL ;
+ int flags = 0 ;
+ int mode = 0 ;
+ BerkeleyDB db ;
+ BerkeleyDB__Txn txn = NULL ;
+ char * enc_passwd = NULL ;
+ int enc_flags = 0 ;
+
+ hash = (HV*) SvRV(ref) ;
+ SetValue_pv(file, "Fname", char*) ;
+ SetValue_pv(subname, "Subname", char *) ;
+ SetValue_ov(dbenv, "Env", BerkeleyDB__Env) ;
+ ref_dbenv = sv ;
+ SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ;
+ SetValue_iv(flags, "Flags") ;
+ SetValue_iv(mode, "Mode") ;
+ SetValue_pv(enc_passwd,"Enc_Passwd", char *) ;
+ SetValue_iv(enc_flags, "Enc_Flags") ;
+
+ Zero(&info, 1, DB_INFO) ;
+ SetValue_iv(info.db_cachesize, "Cachesize") ;
+ SetValue_iv(info.db_lorder, "Lorder") ;
+ SetValue_iv(info.db_pagesize, "Pagesize") ;
+ SetValue_iv(info.bt_minkey, "Minkey") ;
+ SetValue_iv(info.q_extentsize, "ExtentSize") ;
+
+
+ SetValue_iv(info.flags, "Property") ;
+ if ((sv = readHash(hash, "Len")) && sv != &PL_sv_undef) {
+ info.re_len = SvIV(sv) ; ;
+ flagSet_DB2(info.flags, DB_FIXEDLEN) ;
+ }
+ if ((sv = readHash(hash, "Pad")) && sv != &PL_sv_undef) {
+ info.re_pad = (u_int32_t)SvPOK(sv) ? *SvPV(sv,PL_na) : SvIV(sv) ; ;
+ flagSet_DB2(info.flags, DB_PAD) ;
+ }
+ ZMALLOC(db, BerkeleyDB_type) ;
+#ifdef ALLOW_RECNO_OFFSET
+ SetValue_iv(db->array_base, "ArrayBase") ;
+ db->array_base = (db->array_base == 0 ? 1 : 0) ;
+#endif /* ALLOW_RECNO_OFFSET */
+
+ RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
+ DB_QUEUE, flags, mode, &info, enc_passwd, enc_flags, hash) ;
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+HV *
+db_stat(db, flags=0)
+ int flags
+ BerkeleyDB::Common db
+ HV * RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+#if DB_VERSION_MAJOR == 2
+ softCrash("$db->db_stat for a Queue needs Berkeley DB 3.x or better") ;
+#else /* Berkeley DB 3, or better */
+ DB_QUEUE_STAT * stat ;
+#ifdef AT_LEAST_DB_4_3
+ db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
+#else
+#ifdef AT_LEAST_DB_3_3
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
+#else
+ db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, flags) ;
+#endif
+#endif
+ if (db->Status) {
+ XSRETURN_UNDEF;
+ } else {
+ RETVAL = (HV*)sv_2mortal((SV*)newHV()) ;
+ hv_store_iv(RETVAL, "qs_magic", stat->qs_magic) ;
+ hv_store_iv(RETVAL, "qs_version", stat->qs_version);
+#ifdef AT_LEAST_DB_3_1
+ hv_store_iv(RETVAL, "qs_nkeys", stat->qs_nkeys);
+ hv_store_iv(RETVAL, "qs_ndata", stat->qs_ndata);
+#else
+ hv_store_iv(RETVAL, "qs_nrecs", stat->qs_nrecs);
+#endif
+ hv_store_iv(RETVAL, "qs_pages", stat->qs_pages);
+ hv_store_iv(RETVAL, "qs_pagesize", stat->qs_pagesize);
+ hv_store_iv(RETVAL, "qs_pgfree", stat->qs_pgfree);
+ hv_store_iv(RETVAL, "qs_re_len", stat->qs_re_len);
+ hv_store_iv(RETVAL, "qs_re_pad", stat->qs_re_pad);
+#ifdef AT_LEAST_DB_3_2
+#else
+ hv_store_iv(RETVAL, "qs_start", stat->qs_start);
+#endif
+ hv_store_iv(RETVAL, "qs_first_recno", stat->qs_first_recno);
+ hv_store_iv(RETVAL, "qs_cur_recno", stat->qs_cur_recno);
+#if DB_VERSION_MAJOR >= 3
+ hv_store_iv(RETVAL, "qs_metaflags", stat->qs_metaflags);
+#endif
+ safefree(stat) ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common PREFIX = dab_
+
+
+DualType
+db_close(db,flags=0)
+ int flags
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ CODE:
+ Trace(("BerkeleyDB::Common::db_close %d\n", db));
+#ifdef STRICT_CLOSE
+ if (db->txn)
+ softCrash("attempted to close a database while a transaction was still open") ;
+ if (db->open_cursors)
+ softCrash("attempted to close a database with %d open cursor(s)",
+ db->open_cursors) ;
+#ifdef AT_LEAST_DB_4_3
+ if (db->open_sequences)
+ softCrash("attempted to close a database with %d open sequence(s)",
+ db->open_sequences) ;
+#endif /* AT_LEAST_DB_4_3 */
+#endif /* STRICT_CLOSE */
+ RETVAL = db->Status = ((db->dbp)->close)(db->dbp, flags) ;
+ if (db->parent_env && db->parent_env->open_dbs)
+ -- db->parent_env->open_dbs ;
+ db->active = FALSE ;
+ hash_delete("BerkeleyDB::Term::Db", (char *)db) ;
+ -- db->open_cursors ;
+ Trace(("end of BerkeleyDB::Common::db_close\n"));
+ OUTPUT:
+ RETVAL
+
+void
+dab__DESTROY(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ saveCurrentDB(db) ;
+ Trace(("In BerkeleyDB::Common::_DESTROY db %d dirty=%d\n", db, PL_dirty)) ;
+ destroyDB(db) ;
+ Trace(("End of BerkeleyDB::Common::DESTROY \n")) ;
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
+#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur)
+#else
+#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur,flags)
+#endif
+BerkeleyDB::Cursor::Raw
+_db_cursor(db, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Common db
+ BerkeleyDB::Cursor RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ ALIAS: __db_write_cursor = 1
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+ DBC * cursor ;
+ saveCurrentDB(db) ;
+ if (ix == 1 && db->cds_enabled) {
+#ifdef AT_LEAST_DB_3
+ flags |= DB_WRITECURSOR;
+#else
+ flags |= DB_RMW;
+#endif
+ }
+ if ((db->Status = db_cursor(db, db->txn, &cursor, flags)) == 0){
+ ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
+ db->open_cursors ++ ;
+ RETVAL->parent_db = db ;
+ RETVAL->cursor = cursor ;
+ RETVAL->dbp = db->dbp ;
+ RETVAL->txn = db->txn ;
+ RETVAL->type = db->type ;
+ RETVAL->recno_or_queue = db->recno_or_queue ;
+ RETVAL->cds_enabled = db->cds_enabled ;
+ RETVAL->filename = my_strdup(db->filename) ;
+ RETVAL->compare = db->compare ;
+ RETVAL->dup_compare = db->dup_compare ;
+#ifdef AT_LEAST_DB_3_3
+ RETVAL->associated = db->associated ;
+ RETVAL->secondary_db = db->secondary_db;
+ RETVAL->primary_recno_or_queue = db->primary_recno_or_queue ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ RETVAL->associated_foreign = db->associated_foreign ;
+#endif
+ RETVAL->prefix = db->prefix ;
+ RETVAL->hash = db->hash ;
+ RETVAL->partial = db->partial ;
+ RETVAL->doff = db->doff ;
+ RETVAL->dlen = db->dlen ;
+ RETVAL->active = TRUE ;
+#ifdef ALLOW_RECNO_OFFSET
+ RETVAL->array_base = db->array_base ;
+#endif /* ALLOW_RECNO_OFFSET */
+#ifdef DBM_FILTERING
+ RETVAL->filtering = FALSE ;
+ RETVAL->filter_fetch_key = db->filter_fetch_key ;
+ RETVAL->filter_store_key = db->filter_store_key ;
+ RETVAL->filter_fetch_value = db->filter_fetch_value ;
+ RETVAL->filter_store_value = db->filter_store_value ;
+#endif
+ /* RETVAL->info ; */
+ hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+BerkeleyDB::Cursor::Raw
+_db_join(db, cursors, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Common db
+ AV * cursors
+ BerkeleyDB::Cursor RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+#if DB_VERSION_MAJOR == 2 && (DB_VERSION_MINOR < 5 || (DB_VERSION_MINOR == 5 && DB_VERSION_PATCH < 2))
+ softCrash("join needs Berkeley DB 2.5.2 or later") ;
+#else /* Berkeley DB >= 2.5.2 */
+ DBC * join_cursor ;
+ DBC ** cursor_list ;
+ I32 count = av_len(cursors) + 1 ;
+ int i ;
+ saveCurrentDB(db) ;
+ if (count < 1 )
+ softCrash("db_join: No cursors in parameter list") ;
+ cursor_list = (DBC **)safemalloc(sizeof(DBC*) * (count + 1));
+ for (i = 0 ; i < count ; ++i) {
+ SV * obj = (SV*) * av_fetch(cursors, i, FALSE) ;
+ IV tmp = SvIV(getInnerObject(obj)) ;
+ BerkeleyDB__Cursor cur = INT2PTR(BerkeleyDB__Cursor, tmp);
+ if (cur->dbp == db->dbp)
+ softCrash("attempted to do a self-join");
+ cursor_list[i] = cur->cursor ;
+ }
+ cursor_list[i] = NULL ;
+#if DB_VERSION_MAJOR == 2
+ if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, flags, &join_cursor)) == 0){
+#else
+ if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, &join_cursor, flags)) == 0){
+#endif
+ ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
+ db->open_cursors ++ ;
+ RETVAL->parent_db = db ;
+ RETVAL->cursor = join_cursor ;
+ RETVAL->dbp = db->dbp ;
+ RETVAL->type = db->type ;
+ RETVAL->filename = my_strdup(db->filename) ;
+ RETVAL->compare = db->compare ;
+ RETVAL->dup_compare = db->dup_compare ;
+#ifdef AT_LEAST_DB_3_3
+ RETVAL->associated = db->associated ;
+ RETVAL->secondary_db = db->secondary_db;
+ RETVAL->primary_recno_or_queue = db->primary_recno_or_queue ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ RETVAL->associated_foreign = db->associated_foreign ;
+#endif
+ RETVAL->prefix = db->prefix ;
+ RETVAL->hash = db->hash ;
+ RETVAL->partial = db->partial ;
+ RETVAL->doff = db->doff ;
+ RETVAL->dlen = db->dlen ;
+ RETVAL->active = TRUE ;
+#ifdef ALLOW_RECNO_OFFSET
+ RETVAL->array_base = db->array_base ;
+#endif /* ALLOW_RECNO_OFFSET */
+#ifdef DBM_FILTERING
+ RETVAL->filtering = FALSE ;
+ RETVAL->filter_fetch_key = db->filter_fetch_key ;
+ RETVAL->filter_store_key = db->filter_store_key ;
+ RETVAL->filter_fetch_value = db->filter_fetch_value ;
+ RETVAL->filter_store_value = db->filter_store_value ;
+#endif
+ /* RETVAL->info ; */
+ hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
+ }
+ safefree(cursor_list) ;
+#endif /* Berkeley DB >= 2.5.2 */
+ }
+ OUTPUT:
+ RETVAL
+
+int
+ArrayOffset(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#ifdef ALLOW_RECNO_OFFSET
+ RETVAL = db->array_base ? 0 : 1 ;
+#else
+ RETVAL = 0 ;
+#endif /* ALLOW_RECNO_OFFSET */
+ OUTPUT:
+ RETVAL
+
+
+bool
+cds_enabled(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ RETVAL = db->cds_enabled ;
+ OUTPUT:
+ RETVAL
+
+
+int
+stat_print(db, flags=0)
+ BerkeleyDB::Common db
+ u_int32_t flags
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$db->stat_print needs Berkeley DB 4.3 or better") ;
+#else
+ RETVAL = db->dbp->stat_print(db->dbp, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+type(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ RETVAL = db->type ;
+ OUTPUT:
+ RETVAL
+
+int
+byteswapped(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+ softCrash("byteswapped needs Berkeley DB 2.5 or later") ;
+#else
+#if DB_VERSION_MAJOR == 2
+ RETVAL = db->dbp->byteswapped ;
+#else
+#ifdef AT_LEAST_DB_3_3
+ db->dbp->get_byteswapped(db->dbp, &RETVAL) ;
+#else
+ RETVAL = db->dbp->get_byteswapped(db->dbp) ;
+#endif
+#endif
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+status(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = db->Status ;
+ OUTPUT:
+ RETVAL
+
+#ifdef DBM_FILTERING
+
+#define setFilter(ftype) \
+ { \
+ if (db->ftype) \
+ RETVAL = sv_mortalcopy(db->ftype) ; \
+ ST(0) = RETVAL ; \
+ if (db->ftype && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db->ftype) ; \
+ db->ftype = NULL ; \
+ } \
+ else if (code) { \
+ if (db->ftype) \
+ sv_setsv(db->ftype, code) ; \
+ else \
+ db->ftype = newSVsv(code) ; \
+ } \
+ }
+
+
+SV *
+filter_fetch_key(db, code)
+ BerkeleyDB::Common db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_fetch_key, code) ;
+
+SV *
+filter_store_key(db, code)
+ BerkeleyDB::Common db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_store_key, code) ;
+
+SV *
+filter_fetch_value(db, code)
+ BerkeleyDB::Common db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_fetch_value, code) ;
+
+SV *
+filter_store_value(db, code)
+ BerkeleyDB::Common db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_store_value, code) ;
+
+#endif /* DBM_FILTERING */
+
+void
+partial_set(db, offset, length)
+ BerkeleyDB::Common db
+ u_int32_t offset
+ u_int32_t length
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ PPCODE:
+ if (GIMME == G_ARRAY) {
+ XPUSHs(sv_2mortal(newSViv(db->partial == DB_DBT_PARTIAL))) ;
+ XPUSHs(sv_2mortal(newSViv(db->doff))) ;
+ XPUSHs(sv_2mortal(newSViv(db->dlen))) ;
+ }
+ db->partial = DB_DBT_PARTIAL ;
+ db->doff = offset ;
+ db->dlen = length ;
+
+
+void
+partial_clear(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ PPCODE:
+ if (GIMME == G_ARRAY) {
+ XPUSHs(sv_2mortal(newSViv(db->partial == DB_DBT_PARTIAL))) ;
+ XPUSHs(sv_2mortal(newSViv(db->doff))) ;
+ XPUSHs(sv_2mortal(newSViv(db->dlen))) ;
+ }
+ db->partial =
+ db->doff =
+ db->dlen = 0 ;
+
+
+#define db_del(db, key, flags) \
+ (db->Status = ((db->dbp)->del)(db->dbp, db->txn, &key, flags))
+DualType
+db_del(db, key, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ DBTKEY key
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ Trace(("db_del db[%p] in [%p] txn[%p] key[%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, flags)) ;
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+
+
+#ifdef AT_LEAST_DB_3
+# ifdef AT_LEAST_DB_3_2
+# define writeToKey() (flagSet(DB_CONSUME)||flagSet(DB_CONSUME_WAIT)||flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO))
+# else
+# define writeToKey() (flagSet(DB_CONSUME)||flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO))
+# endif
+#else
+#define writeToKey() (flagSet(DB_GET_BOTH)||flagSet(DB_SET_RECNO))
+#endif
+#define db_get(db, key, data, flags) \
+ (db->Status = ((db->dbp)->get)(db->dbp, db->txn, &key, &data, flags))
+DualType
+db_get(db, key, data, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ DBTKEY_B key
+ DBT_OPT data
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ SetPartial(data,db) ;
+ Trace(("db_get db[%p] in [%p] txn[%p] key [%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, flags)) ;
+ RETVAL = db_get(db, key, data, flags);
+ Trace((" RETVAL %d\n", RETVAL));
+ OUTPUT:
+ RETVAL
+ key if (writeToKey()) OutputKey(ST(1), key) ;
+ data
+
+#define db_exists(db, key, flags) \
+ (db->Status = ((db->dbp)->exists)(db->dbp, db->txn, &key, flags))
+DualType
+db_exists(db, key, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ DBTKEY_B key
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_4_6
+ softCrash("db_exists needs at least Berkeley DB 4.6");
+#else
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ Trace(("db_exists db[%p] in [%p] txn[%p] key [%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, flags)) ;
+ RETVAL = db_exists(db, key, flags);
+ Trace((" RETVAL %d\n", RETVAL));
+#endif
+ OUTPUT:
+ RETVAL
+
+
+#define db_pget(db, key, pkey, data, flags) \
+ (db->Status = ((db->dbp)->pget)(db->dbp, db->txn, &key, &pkey, &data, flags))
+DualType
+db_pget(db, key, pkey, data, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ DBTKEY_B key
+ DBTKEY_Bpr pkey
+ DBT_OPT data
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_3_3
+ softCrash("db_pget needs at least Berkeley DB 3.3");
+#else
+ Trace(("db_pget db [%p] in [%p] txn [%p] flags [%d]\n", db->dbp, db, db->txn, flags)) ;
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ SetPartial(data,db) ;
+ RETVAL = db_pget(db, key, pkey, data, flags);
+ Trace((" RETVAL %d\n", RETVAL));
+#endif
+ OUTPUT:
+ RETVAL
+ key if (writeToKey()) OutputKey(ST(1), key) ;
+ pkey
+ data
+
+#define db_put(db,key,data,flag) \
+ (db->Status = (db->dbp->put)(db->dbp,db->txn,&key,&data,flag))
+DualType
+db_put(db, key, data, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ DBTKEY key
+ DBT data
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ /* SetPartial(data,db) ; */
+ Trace(("db_put db[%p] in [%p] txn[%p] key[%.*s] data [%.*s] flags[%d]\n", db->dbp, db, db->txn, key.size, key.data, data.size, data.data, flags)) ;
+ RETVAL = db_put(db, key, data, flags);
+ Trace((" RETVAL %d\n", RETVAL));
+ OUTPUT:
+ RETVAL
+ key if (flagSet(DB_APPEND)) OutputKey(ST(1), key) ;
+
+#define db_key_range(db, key, range, flags) \
+ (db->Status = ((db->dbp)->key_range)(db->dbp, db->txn, &key, &range, flags))
+DualType
+db_key_range(db, key, less, equal, greater, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Common db
+ DBTKEY_B key
+ double less = 0.0 ;
+ double equal = 0.0 ;
+ double greater = 0.0 ;
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_3_1
+ softCrash("key_range needs Berkeley DB 3.1.x or later") ;
+#else
+ DB_KEY_RANGE range ;
+ range.less = range.equal = range.greater = 0.0 ;
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ RETVAL = db_key_range(db, key, range, flags);
+ if (RETVAL == 0) {
+ less = range.less ;
+ equal = range.equal;
+ greater = range.greater;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+ less
+ equal
+ greater
+
+
+#define db_fd(d, x) (db->Status = (db->dbp->fd)(db->dbp, &x))
+int
+db_fd(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ saveCurrentDB(db) ;
+ db_fd(db, RETVAL) ;
+ OUTPUT:
+ RETVAL
+
+
+#define db_sync(db, fl) (db->Status = (db->dbp->sync)(db->dbp, fl))
+DualType
+db_sync(db, flags=0)
+ u_int flags
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+
+void
+_Txn(db, txn=NULL)
+ BerkeleyDB::Common db
+ BerkeleyDB::Txn txn
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+ if (txn) {
+ Trace(("_Txn[%p] in[%p] active [%d]\n", txn->txn, txn, txn->active));
+ ckActive_Transaction(txn->active) ;
+ db->txn = txn->txn ;
+ }
+ else {
+ Trace(("_Txn[undef] \n"));
+ db->txn = NULL ;
+ }
+
+
+#define db_truncate(db, countp, flags) \
+ (db->Status = ((db->dbp)->truncate)(db->dbp, db->txn, &countp, flags))
+DualType
+truncate(db, countp, flags=0)
+ BerkeleyDB::Common db
+ u_int32_t countp = NO_INIT
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_3
+ softCrash("truncate needs Berkeley DB 3.3 or later") ;
+#else
+ saveCurrentDB(db) ;
+ RETVAL = db_truncate(db, countp, flags);
+#endif
+ OUTPUT:
+ RETVAL
+ countp
+
+#ifdef AT_LEAST_DB_4_1
+# define db_associate(db, sec, cb, flags)\
+ (db->Status = ((db->dbp)->associate)(db->dbp, db->txn, sec->dbp, &cb, flags))
+#else
+# define db_associate(db, sec, cb, flags)\
+ (db->Status = ((db->dbp)->associate)(db->dbp, sec->dbp, &cb, flags))
+#endif
+DualType
+associate(db, secondary, callback, flags=0)
+ BerkeleyDB::Common db
+ BerkeleyDB::Common secondary
+ SV* callback
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_3_3
+ softCrash("associate needs Berkeley DB 3.3 or later") ;
+#else
+ saveCurrentDB(db) ;
+ /* db->associated = newSVsv(callback) ; */
+ secondary->associated = newSVsv(callback) ;
+ secondary->primary_recno_or_queue = db->recno_or_queue ;
+ /* secondary->dbp->app_private = secondary->associated ; */
+ secondary->secondary_db = TRUE;
+ if (secondary->recno_or_queue)
+ RETVAL = db_associate(db, secondary, associate_cb_recno, flags);
+ else
+ RETVAL = db_associate(db, secondary, associate_cb, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+#define db_associate_foreign(db, sec, cb, flags)\
+ (db->Status = ((db->dbp)->associate_foreign)(db->dbp, sec->dbp, cb, flags))
+DualType
+associate_foreign(db, secondary, callback, flags)
+ BerkeleyDB::Common db
+ BerkeleyDB::Common secondary
+ SV* callback
+ u_int32_t flags
+ foreign_cb_type callback_ptr = NULL;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(db->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_8
+ softCrash("associate_foreign needs Berkeley DB 4.8 or later") ;
+#else
+ saveCurrentDB(db) ;
+ if (callback != &PL_sv_undef)
+ {
+ //softCrash("associate_foreign does not support callbacks yet") ;
+ secondary->associated_foreign = newSVsv(callback) ;
+ callback_ptr = ( secondary->recno_or_queue
+ ? associate_foreign_cb_recno
+ : associate_foreign_cb);
+ }
+ secondary->primary_recno_or_queue = db->recno_or_queue ;
+ secondary->secondary_db = TRUE;
+ RETVAL = db_associate_foreign(db, secondary, callback_ptr, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+compact(db, start=NULL, stop=NULL, c_data=NULL, flags=0, end=NULL)
+ PREINIT:
+ dMY_CXT;
+ PREINIT:
+ DBTKEY end_key;
+ INPUT:
+ BerkeleyDB::Common db
+ SVnull* start
+ SVnull* stop
+ SVnull* c_data
+ u_int32_t flags
+ SVnull* end
+ CODE:
+ {
+#ifndef AT_LEAST_DB_4_4
+ softCrash("compact needs Berkeley DB 4.4 or later") ;
+#else
+ DBTKEY start_key;
+ DBTKEY stop_key;
+ DBTKEY* start_p = NULL;
+ DBTKEY* stop_p = NULL;
+ DBTKEY* end_p = NULL;
+ DB_COMPACT cmpt;
+ DB_COMPACT* cmpt_p = NULL;
+ SV * sv;
+ HV* hash = NULL;
+
+ DBT_clear(start_key);
+ DBT_clear(stop_key);
+ DBT_clear(end_key);
+ Zero(&cmpt, 1, DB_COMPACT) ;
+ ckActive_Database(db->active) ;
+ saveCurrentDB(db) ;
+ if (start && SvOK(start)) {
+ start_p = &start_key;
+ DBM_ckFilter(start, filter_store_key, "filter_store_key");
+ GetKey(db, start, start_p);
+ }
+ if (stop && SvOK(stop)) {
+ stop_p = &stop_key;
+ DBM_ckFilter(stop, filter_store_key, "filter_store_key");
+ GetKey(db, stop, stop_p);
+ }
+ if (end) {
+ end_p = &end_key;
+ }
+ if (c_data && SvOK(c_data)) {
+ hash = (HV*) SvRV(c_data) ;
+ cmpt_p = & cmpt;
+ cmpt.compact_fillpercent = GetValue_iv(hash,"compact_fillpercent") ;
+ cmpt.compact_timeout = (db_timeout_t) GetValue_iv(hash, "compact_timeout");
+ }
+ RETVAL = (db->dbp)->compact(db->dbp, db->txn, start_p, stop_p, cmpt_p, flags, end_p);
+ if (RETVAL == 0 && hash) {
+ hv_store_iv(hash, "compact_deadlock", cmpt.compact_deadlock) ;
+ hv_store_iv(hash, "compact_levels", cmpt.compact_levels) ;
+ hv_store_iv(hash, "compact_pages_free", cmpt.compact_pages_free) ;
+ hv_store_iv(hash, "compact_pages_examine", cmpt.compact_pages_examine) ;
+ hv_store_iv(hash, "compact_pages_truncated", cmpt.compact_pages_truncated) ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+ end if (RETVAL == 0 && end) OutputValue_B(ST(5), end_key) ;
+
+
+MODULE = BerkeleyDB::Cursor PACKAGE = BerkeleyDB::Cursor PREFIX = cu_
+
+BerkeleyDB::Cursor::Raw
+_c_dup(db, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Cursor db
+ BerkeleyDB::Cursor RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ saveCurrentDB(db->parent_db);
+ ckActive_Database(db->active) ;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_3
+ softCrash("c_dup needs at least Berkeley DB 3.0.x");
+#else
+ DBC * newcursor ;
+ db->Status = ((db->cursor)->c_dup)(db->cursor, &newcursor, flags) ;
+ if (db->Status == 0){
+ ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
+ db->parent_db->open_cursors ++ ;
+ RETVAL->parent_db = db->parent_db ;
+ RETVAL->cursor = newcursor ;
+ RETVAL->dbp = db->dbp ;
+ RETVAL->type = db->type ;
+ RETVAL->recno_or_queue = db->recno_or_queue ;
+ RETVAL->primary_recno_or_queue = db->primary_recno_or_queue ;
+ RETVAL->cds_enabled = db->cds_enabled ;
+ RETVAL->filename = my_strdup(db->filename) ;
+ RETVAL->compare = db->compare ;
+ RETVAL->dup_compare = db->dup_compare ;
+#ifdef AT_LEAST_DB_3_3
+ RETVAL->associated = db->associated ;
+#endif
+#ifdef AT_LEAST_DB_4_8
+ RETVAL->associated_foreign = db->associated_foreign ;
+#endif
+ RETVAL->prefix = db->prefix ;
+ RETVAL->hash = db->hash ;
+ RETVAL->partial = db->partial ;
+ RETVAL->doff = db->doff ;
+ RETVAL->dlen = db->dlen ;
+ RETVAL->active = TRUE ;
+#ifdef ALLOW_RECNO_OFFSET
+ RETVAL->array_base = db->array_base ;
+#endif /* ALLOW_RECNO_OFFSET */
+#ifdef DBM_FILTERING
+ RETVAL->filtering = FALSE ;
+ RETVAL->filter_fetch_key = db->filter_fetch_key ;
+ RETVAL->filter_store_key = db->filter_store_key ;
+ RETVAL->filter_fetch_value = db->filter_fetch_value ;
+ RETVAL->filter_store_value = db->filter_store_value ;
+#endif /* DBM_FILTERING */
+ /* RETVAL->info ; */
+ hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+DualType
+_c_close(db)
+ BerkeleyDB::Cursor db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ;
+ CODE:
+ RETVAL = db->Status =
+ ((db->cursor)->c_close)(db->cursor) ;
+ db->active = FALSE ;
+ if (db->parent_db->open_cursors)
+ -- db->parent_db->open_cursors ;
+ OUTPUT:
+ RETVAL
+
+void
+_DESTROY(db)
+ BerkeleyDB::Cursor db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ saveCurrentDB(db->parent_db);
+ Trace(("In BerkeleyDB::Cursor::_DESTROY db %d dirty=%d active=%d\n", db, PL_dirty, db->active));
+ hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ;
+ if (db->active)
+ ((db->cursor)->c_close)(db->cursor) ;
+ if (db->parent_db->open_cursors)
+ -- db->parent_db->open_cursors ;
+ Safefree(db->filename) ;
+ Safefree(db) ;
+ Trace(("End of BerkeleyDB::Cursor::_DESTROY\n")) ;
+
+DualType
+status(db)
+ BerkeleyDB::Cursor db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = db->Status ;
+ OUTPUT:
+ RETVAL
+
+
+#define cu_c_del(c,f) (c->Status = ((c->cursor)->c_del)(c->cursor,f))
+DualType
+cu_c_del(db, flags=0)
+ int flags
+ BerkeleyDB::Cursor db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ OUTPUT:
+ RETVAL
+
+
+#define cu_c_get(c,k,d,f) (c->Status = (c->cursor->c_get)(c->cursor,&k,&d,f))
+DualType
+cu_c_get(db, key, data, flags=0)
+ int flags
+ BerkeleyDB::Cursor db
+ DBTKEY_B key
+ DBT_B data
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ Trace(("c_get db [%p] in [%p] flags [%d]\n", db->dbp, db, flags)) ;
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ /* DBT_clear(key); */
+ /* DBT_clear(data); */
+ SetPartial(data,db) ;
+ Trace(("c_get end\n")) ;
+ OUTPUT:
+ RETVAL
+ key
+ data if (! flagSet(DB_JOIN_ITEM)) OutputValue_B(ST(2), data) ;
+
+#define cu_c_pget(c,k,p,d,f) (c->Status = (c->secondary_db ? (c->cursor->c_pget)(c->cursor,&k,&p,&d,f) : EINVAL))
+DualType
+cu_c_pget(db, key, pkey, data, flags=0)
+ int flags
+ BerkeleyDB::Cursor db
+ DBTKEY_B key
+ DBTKEY_Bpr pkey
+ DBT_B data
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_3_3
+ softCrash("db_c_pget needs at least Berkeley DB 3.3");
+#else
+ Trace(("c_pget db [%d] flags [%d]\n", db, flags)) ;
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ SetPartial(data,db) ;
+ RETVAL = cu_c_pget(db, key, pkey, data, flags);
+ Trace(("c_pget end\n")) ;
+#endif
+ OUTPUT:
+ RETVAL
+ key if (writeToKey()) OutputKey(ST(1), key) ;
+ pkey
+ data
+
+
+
+#define cu_c_put(c,k,d,f) (c->Status = (c->cursor->c_put)(c->cursor,&k,&d,f))
+DualType
+cu_c_put(db, key, data, flags=0)
+ int flags
+ BerkeleyDB::Cursor db
+ DBTKEY key
+ DBT data
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ /* SetPartial(data,db) ; */
+ OUTPUT:
+ RETVAL
+
+#define cu_c_count(c,p,f) (c->Status = (c->cursor->c_count)(c->cursor,&p,f))
+DualType
+cu_c_count(db, count, flags=0)
+ int flags
+ BerkeleyDB::Cursor db
+ u_int32_t count = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifndef AT_LEAST_DB_3_1
+ softCrash("c_count needs at least Berkeley DB 3.1.x");
+#else
+ Trace(("c_get count [%d] flags [%d]\n", db, flags)) ;
+ saveCurrentDB(db->parent_db);
+ ckActive_Cursor(db->active) ;
+ RETVAL = cu_c_count(db, count, flags) ;
+ Trace((" c_count got %d duplicates\n", count)) ;
+#endif
+ OUTPUT:
+ RETVAL
+ count
+
+MODULE = BerkeleyDB::TxnMgr PACKAGE = BerkeleyDB::TxnMgr PREFIX = xx_
+
+BerkeleyDB::Txn::Raw
+_txn_begin(txnmgr, pid=NULL, flags=0)
+ u_int32_t flags
+ BerkeleyDB::TxnMgr txnmgr
+ BerkeleyDB::Txn pid
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DB_TXN *txn ;
+ DB_TXN *p_id = NULL ;
+#if DB_VERSION_MAJOR == 2
+ if (txnmgr->env->Env->tx_info == NULL)
+ softCrash("Transaction Manager not enabled") ;
+#endif
+ if (pid)
+ p_id = pid->txn ;
+ txnmgr->env->TxnMgrStatus =
+#if DB_VERSION_MAJOR == 2
+ txn_begin(txnmgr->env->Env->tx_info, p_id, &txn) ;
+#else
+# ifdef AT_LEAST_DB_4
+ txnmgr->env->Env->txn_begin(txnmgr->env->Env, p_id, &txn, flags) ;
+# else
+ txn_begin(txnmgr->env->Env, p_id, &txn, flags) ;
+# endif
+#endif
+ if (txnmgr->env->TxnMgrStatus == 0) {
+ ZMALLOC(RETVAL, BerkeleyDB_Txn_type) ;
+ RETVAL->txn = txn ;
+ RETVAL->active = TRUE ;
+ Trace(("_txn_begin created txn [%d] in [%d]\n", txn, RETVAL));
+ hash_store_iv("BerkeleyDB::Term::Txn", (char *)RETVAL, 1) ;
+ }
+ else
+ RETVAL = NULL ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+DualType
+status(mgr)
+ BerkeleyDB::TxnMgr mgr
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = mgr->env->TxnMgrStatus ;
+ OUTPUT:
+ RETVAL
+
+
+void
+_DESTROY(mgr)
+ BerkeleyDB::TxnMgr mgr
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ Trace(("In BerkeleyDB::TxnMgr::DESTROY dirty=%d\n", PL_dirty)) ;
+ Safefree(mgr) ;
+ Trace(("End of BerkeleyDB::TxnMgr::DESTROY\n")) ;
+
+DualType
+txn_close(txnp)
+ BerkeleyDB::TxnMgr txnp
+ NOT_IMPLEMENTED_YET
+
+
+#if DB_VERSION_MAJOR == 2
+# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env->tx_info, k, m)
+#else
+# ifdef AT_LEAST_DB_4
+# define xx_txn_checkpoint(e,k,m,f) e->env->Env->txn_checkpoint(e->env->Env, k, m, f)
+# else
+# ifdef AT_LEAST_DB_3_1
+# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env, k, m, 0)
+# else
+# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env, k, m)
+# endif
+# endif
+#endif
+DualType
+xx_txn_checkpoint(txnp, kbyte, min, flags=0)
+ BerkeleyDB::TxnMgr txnp
+ long kbyte
+ long min
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+
+HV *
+txn_stat(txnp)
+ BerkeleyDB::TxnMgr txnp
+ HV * RETVAL = NULL ;
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DB_TXN_STAT * stat ;
+#ifdef AT_LEAST_DB_4
+ if(txnp->env->Env->txn_stat(txnp->env->Env, &stat, 0) == 0) {
+#else
+# ifdef AT_LEAST_DB_3_3
+ if(txn_stat(txnp->env->Env, &stat) == 0) {
+# else
+# if DB_VERSION_MAJOR == 2
+ if(txn_stat(txnp->env->Env->tx_info, &stat, safemalloc) == 0) {
+# else
+ if(txn_stat(txnp->env->Env, &stat, safemalloc) == 0) {
+# endif
+# endif
+#endif
+ RETVAL = (HV*)sv_2mortal((SV*)newHV()) ;
+ hv_store_iv(RETVAL, "st_time_ckp", stat->st_time_ckp) ;
+ hv_store_iv(RETVAL, "st_last_txnid", stat->st_last_txnid) ;
+ hv_store_iv(RETVAL, "st_maxtxns", stat->st_maxtxns) ;
+ hv_store_iv(RETVAL, "st_naborts", stat->st_naborts) ;
+ hv_store_iv(RETVAL, "st_nbegins", stat->st_nbegins) ;
+ hv_store_iv(RETVAL, "st_ncommits", stat->st_ncommits) ;
+ hv_store_iv(RETVAL, "st_nactive", stat->st_nactive) ;
+#if DB_VERSION_MAJOR > 2
+ hv_store_iv(RETVAL, "st_maxnactive", stat->st_maxnactive) ;
+ hv_store_iv(RETVAL, "st_regsize", stat->st_regsize) ;
+ hv_store_iv(RETVAL, "st_region_wait", stat->st_region_wait) ;
+ hv_store_iv(RETVAL, "st_region_nowait", stat->st_region_nowait) ;
+#endif
+ safefree(stat) ;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+
+BerkeleyDB::TxnMgr
+txn_open(dir, flags, mode, dbenv)
+ int flags
+ const char * dir
+ int mode
+ BerkeleyDB::Env dbenv
+ NOT_IMPLEMENTED_YET
+
+
+MODULE = BerkeleyDB::Txn PACKAGE = BerkeleyDB::Txn PREFIX = xx_
+
+DualType
+status(tid)
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ RETVAL = tid->Status ;
+ OUTPUT:
+ RETVAL
+
+int
+set_timeout(txn, timeout, flags=0)
+ BerkeleyDB::Txn txn
+ db_timeout_t timeout
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Transaction(txn->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4
+ softCrash("$env->set_timeout needs Berkeley DB 4.x or better") ;
+#else
+ RETVAL = txn->Status = txn->txn->set_timeout(txn->txn, timeout, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+set_tx_max(env, max)
+ BerkeleyDB::Env env
+ u_int32_t max
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_2_3
+ softCrash("$env->set_tx_max needs Berkeley DB 2_3.x or better") ;
+#else
+ dieIfEnvOpened(env, "set_tx_max");
+ RETVAL = env->Status = env->Env->set_tx_max(env->Env, max);
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+get_tx_max(env, max)
+ BerkeleyDB::Env env
+ u_int32_t max = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Database(env->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_2_3
+ softCrash("$env->get_tx_max needs Berkeley DB 2_3.x or better") ;
+#else
+ RETVAL = env->Status = env->Env->get_tx_max(env->Env, &max);
+#endif
+ OUTPUT:
+ RETVAL
+ max
+
+void
+_DESTROY(tid)
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ Trace(("In BerkeleyDB::Txn::_DESTROY txn [%d] active [%d] dirty=%d\n", tid->txn, tid->active, PL_dirty)) ;
+ if (tid->active)
+#ifdef AT_LEAST_DB_4
+ tid->txn->abort(tid->txn) ;
+#else
+ txn_abort(tid->txn) ;
+#endif
+ hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ;
+ Safefree(tid) ;
+ Trace(("End of BerkeleyDB::Txn::DESTROY\n")) ;
+
+#define xx_txn_unlink(d,f,e) txn_unlink(d,f,&(e->Env))
+DualType
+xx_txn_unlink(dir, force, dbenv)
+ const char * dir
+ int force
+ BerkeleyDB::Env dbenv
+ NOT_IMPLEMENTED_YET
+
+#ifdef AT_LEAST_DB_4
+# define xx_txn_prepare(t) (t->Status = t->txn->prepare(t->txn, 0))
+#else
+# ifdef AT_LEAST_DB_3_3
+# define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn, 0))
+# else
+# define xx_txn_prepare(t) (t->Status = txn_prepare(t->txn))
+# endif
+#endif
+DualType
+xx_txn_prepare(tid)
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Transaction(tid->active) ;
+
+#ifdef AT_LEAST_DB_4
+# define _txn_commit(t,flags) (t->Status = t->txn->commit(t->txn, flags))
+#else
+# if DB_VERSION_MAJOR == 2
+# define _txn_commit(t,flags) (t->Status = txn_commit(t->txn))
+# else
+# define _txn_commit(t, flags) (t->Status = txn_commit(t->txn, flags))
+# endif
+#endif
+DualType
+_txn_commit(tid, flags=0)
+ u_int32_t flags
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Transaction(tid->active) ;
+ hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ;
+ tid->active = FALSE ;
+
+#ifdef AT_LEAST_DB_4
+# define _txn_abort(t) (t->Status = t->txn->abort(t->txn))
+#else
+# define _txn_abort(t) (t->Status = txn_abort(t->txn))
+#endif
+DualType
+_txn_abort(tid)
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Transaction(tid->active) ;
+ hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ;
+ tid->active = FALSE ;
+
+#ifdef AT_LEAST_DB_4
+# define _txn_discard(t,f) (t->Status = t->txn->discard(t->txn, f))
+#else
+# ifdef AT_LEAST_DB_3_3_4
+# define _txn_discard(t,f) (t->Status = txn_discard(t->txn, f))
+# else
+# define _txn_discard(t,f) (int)softCrash("txn_discard needs Berkeley DB 3.3.4 or better") ;
+# endif
+#endif
+DualType
+_txn_discard(tid, flags=0)
+ BerkeleyDB::Txn tid
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Transaction(tid->active) ;
+ hash_delete("BerkeleyDB::Term::Txn", (char *)tid) ;
+ tid->active = FALSE ;
+
+#ifdef AT_LEAST_DB_4
+# define xx_txn_id(t) t->txn->id(t->txn)
+#else
+# define xx_txn_id(t) txn_id(t->txn)
+#endif
+u_int32_t
+xx_txn_id(tid)
+ BerkeleyDB::Txn tid
+ PREINIT:
+ dMY_CXT;
+
+MODULE = BerkeleyDB::_tiedHash PACKAGE = BerkeleyDB::_tiedHash
+
+int
+FIRSTKEY(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ DBC * cursor ;
+
+ /*
+ TODO!
+ set partial value to 0 - to eliminate the retrieval of
+ the value need to store any existing partial settings &
+ restore at the end.
+
+ */
+ saveCurrentDB(db) ;
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ /* If necessary create a cursor for FIRSTKEY/NEXTKEY use */
+ if (!db->cursor &&
+ (db->Status = db_cursor(db, db->txn, &cursor, 0)) == 0 )
+ db->cursor = cursor ;
+
+ if (db->cursor)
+ RETVAL = (db->Status) =
+ ((db->cursor)->c_get)(db->cursor, &key, &value, DB_FIRST);
+ else
+ RETVAL = db->Status ;
+ /* check for end of cursor */
+ if (RETVAL == DB_NOTFOUND) {
+ ((db->cursor)->c_close)(db->cursor) ;
+ db->cursor = NULL ;
+ }
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key)
+ }
+
+
+
+int
+NEXTKEY(db, key)
+ BerkeleyDB::Common db
+ DBTKEY key = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DBT value ;
+
+ saveCurrentDB(db) ;
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ key.flags = 0 ;
+ RETVAL = (db->Status) =
+ ((db->cursor)->c_get)(db->cursor, &key, &value, DB_NEXT);
+
+ /* check for end of cursor */
+ if (RETVAL == DB_NOTFOUND) {
+ ((db->cursor)->c_close)(db->cursor) ;
+ db->cursor = NULL ;
+ }
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key)
+ }
+
+MODULE = BerkeleyDB::_tiedArray PACKAGE = BerkeleyDB::_tiedArray
+
+I32
+FETCHSIZE(db)
+ BerkeleyDB::Common db
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ saveCurrentDB(db) ;
+ RETVAL = GetArrayLength(db) ;
+ OUTPUT:
+ RETVAL
+
+
+MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common
+
+BerkeleyDB::Sequence
+db_create_sequence(db, flags=0)
+ BerkeleyDB::Common db
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->create_sequence needs Berkeley DB 4.3.x or better") ;
+#else
+ DB_SEQUENCE * seq ;
+ saveCurrentDB(db);
+ RETVAL = NULL;
+ if (db_sequence_create(&seq, db->dbp, flags) == 0)
+ {
+ ZMALLOC(RETVAL, BerkeleyDB_Sequence_type);
+ RETVAL->db = db;
+ RETVAL->seq = seq;
+ RETVAL->active = TRUE;
+ ++ db->open_sequences ;
+ }
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+
+MODULE = BerkeleyDB::Sequence PACKAGE = BerkeleyDB::Sequence PREFIX = seq_
+
+DualType
+open(seq, key, flags=0)
+ BerkeleyDB::Sequence seq
+ DBTKEY_seq key
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->create_sequence needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->open(seq->seq, seq->db->txn, &key, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+close(seq,flags=0)
+ BerkeleyDB::Sequence seq;
+ u_int32_t flags;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->close needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = 0;
+ if (seq->active) {
+ -- seq->db->open_sequences;
+ RETVAL = (seq->seq->close)(seq->seq, flags);
+ }
+ seq->active = FALSE;
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+remove(seq,flags=0)
+ BerkeleyDB::Sequence seq;
+ u_int32_t flags;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->remove needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = 0;
+ if (seq->active)
+ RETVAL = seq->seq->remove(seq->seq, seq->db->txn, flags);
+ seq->active = FALSE;
+#endif
+ OUTPUT:
+ RETVAL
+
+void
+DESTROY(seq)
+ BerkeleyDB::Sequence seq
+ PREINIT:
+ dMY_CXT;
+ CODE:
+#ifdef AT_LEAST_DB_4_3
+ if (seq->active)
+ (seq->seq->close)(seq->seq, 0);
+ Safefree(seq);
+#endif
+
+DualType
+get(seq, element, delta=1, flags=0)
+ BerkeleyDB::Sequence seq;
+ IV delta;
+ db_seq_t element = NO_INIT
+ u_int32_t flags;
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->get needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->get(seq->seq, seq->db->txn, delta, &element, flags);
+#endif
+ OUTPUT:
+ RETVAL
+ element
+
+DualType
+get_key(seq, key)
+ BerkeleyDB::Sequence seq;
+ DBTKEY_seq key = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->get_key needs Berkeley DB 4.3.x or better") ;
+#else
+ DBT_clear(key);
+ RETVAL = seq->seq->get_key(seq->seq, &key);
+#endif
+ OUTPUT:
+ RETVAL
+ key
+
+DualType
+initial_value(seq, low, high=0)
+ BerkeleyDB::Sequence seq;
+ int low
+ int high
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->initial_value needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->initial_value(seq->seq, (db_seq_t)(high << 32 + low));
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+set_cachesize(seq, size)
+ BerkeleyDB::Sequence seq;
+ int32_t size
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->set_cachesize needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->set_cachesize(seq->seq, size);
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+get_cachesize(seq, size)
+ BerkeleyDB::Sequence seq;
+ int32_t size = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->get_cachesize needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->get_cachesize(seq->seq, &size);
+#endif
+ OUTPUT:
+ RETVAL
+ size
+
+DualType
+set_flags(seq, flags)
+ BerkeleyDB::Sequence seq;
+ u_int32_t flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->set_flags needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->set_flags(seq->seq, flags);
+#endif
+ OUTPUT:
+ RETVAL
+
+DualType
+get_flags(seq, flags)
+ BerkeleyDB::Sequence seq;
+ u_int32_t flags = NO_INIT
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ ckActive_Sequence(seq->active) ;
+ CODE:
+#ifndef AT_LEAST_DB_4_3
+ softCrash("$seq->get_flags needs Berkeley DB 4.3.x or better") ;
+#else
+ RETVAL = seq->seq->get_flags(seq->seq, &flags);
+#endif
+ OUTPUT:
+ RETVAL
+ flags
+
+DualType
+set_range(seq)
+ BerkeleyDB::Sequence seq;
+ NOT_IMPLEMENTED_YET
+
+DualType
+stat(seq)
+ BerkeleyDB::Sequence seq;
+ NOT_IMPLEMENTED_YET
+
+
+MODULE = BerkeleyDB PACKAGE = BerkeleyDB
+
+BOOT:
+ {
+#ifdef dTHX
+ dTHX;
+#endif
+ SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
+ SV * version_sv = perl_get_sv("BerkeleyDB::db_version", GV_ADD|GV_ADDMULTI) ;
+ SV * ver_sv = perl_get_sv("BerkeleyDB::db_ver", GV_ADD|GV_ADDMULTI) ;
+ int Major, Minor, Patch ;
+ MY_CXT_INIT;
+ (void)db_version(&Major, &Minor, &Patch) ;
+ /* Check that the versions of db.h and libdb.a are the same */
+ if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR
+ || Patch != DB_VERSION_PATCH)
+ croak("\nBerkeleyDB needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n",
+ DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH,
+ Major, Minor, Patch) ;
+
+ if (Major < 2 || (Major == 2 && Minor < 6))
+ {
+ croak("BerkeleyDB needs Berkeley DB 2.6 or greater. This is %d.%d.%d\n",
+ Major, Minor, Patch) ;
+ }
+ sv_setpvf(version_sv, "%d.%d", Major, Minor) ;
+ sv_setpvf(ver_sv, "%d.%03d%03d", Major, Minor, Patch) ;
+ sv_setpv(sv_err, "");
+
+ DBT_clear(empty) ;
+ empty.data = &zero ;
+ empty.size = sizeof(db_recno_t) ;
+ empty.flags = 0 ;
+
+ }
+
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB/Btree.pm b/lang/perl/BerkeleyDB/BerkeleyDB/Btree.pm
new file mode 100644
index 00000000..ba9a9c00
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB/Btree.pm
@@ -0,0 +1,8 @@
+
+package BerkeleyDB::Btree ;
+
+# This file is only used for MLDBM
+
+use BerkeleyDB ;
+
+1 ;
diff --git a/lang/perl/BerkeleyDB/BerkeleyDB/Hash.pm b/lang/perl/BerkeleyDB/BerkeleyDB/Hash.pm
new file mode 100644
index 00000000..8e7bc7e7
--- /dev/null
+++ b/lang/perl/BerkeleyDB/BerkeleyDB/Hash.pm
@@ -0,0 +1,8 @@
+
+package BerkeleyDB::Hash ;
+
+# This file is only used for MLDBM
+
+use BerkeleyDB ;
+
+1 ;
diff --git a/lang/perl/BerkeleyDB/Changes b/lang/perl/BerkeleyDB/Changes
new file mode 100644
index 00000000..17065ea4
--- /dev/null
+++ b/lang/perl/BerkeleyDB/Changes
@@ -0,0 +1,428 @@
+Revision history for Perl extension BerkeleyDB.
+
+0.50 10th DEcember 2011
+
+ * Updates for BDB 5.3
+
+0.49 6th August 2011
+
+ * Documentation updated courtesy of Mike Caron
+
+ * croak if attempt to freeze berkeleydb object
+ [RT #69985]
+
+0.48 18th June 2011
+
+ * Fixed test harness issue with Heap.t
+ RT #68818
+
+0.47 1st June 2011
+
+ * Add support for new Heap database format.
+
+ * Changes to build with BDB 5.2
+
+0.46 18th October 2010
+
+ * Fixed bug with db_pget when the DB_GET_BOTH flag is used.
+
+0.45 17th October 2010
+
+ * Fixed bug with c_pget when the DB_GET_BOTH flag is used.
+
+0.44 2nd August 2010
+
+ * Added support for db_exists and lock_detect.
+ Thanks to Alex Lovatt for the patch.
+
+0.43 1st August 2010
+
+ * Changes to build with BDB 5.1
+ - Dropped support for Server option when creating an environment.
+
+ * Documantation updates.
+ RT# 59202
+
+ * Fixed compilation error with MS Visual Studio 2005
+ RT# 59924
+
+0.42 13th March 2010
+
+ * Added $db->Env method to retrieve the environment object from a
+ database object.
+
+ * Get the tied interface to use truncate in the CLEAR method if
+ using a new enough version of Berkeley DB.
+
+0.41 8th January 2010
+
+ * Silence "UNIVERSAL->import is deprecated" in perl 5.11
+ RT# 53518
+
+0.40 7th January 2010
+
+ * Added support for set_tx_max, log_set_config, set_lk_max_lockers,
+ set_lk_max_locks, set_lk_max_objects via the Env constructor.
+ Parameter names are TxMax, LogConfig, MaxLockers, MaxLocks &
+ MaxObjects respectively.
+ RT# 50456
+
+ * seq->seq->close doesn't compile on win32.
+ RT# 49474
+
+0.39 6th June 2009
+
+ * Added support for BDB 4.8
+ - associate_foreign
+ - set_bt_compress (no callbacks as yet).
+
+ * Also added interface to
+ - ENV->stat_print
+ - ENV->txn_stat_print
+
+ * Oldest Perl supported is now 5.005
+
+ * Fixed issue db_stat when it returned a null pointer.
+ (#46312 rt.cpan.org)
+
+ * Fixed issue with DNM Filters & UTF8 support.
+ Patch supplied by Torsten Foertsch.
+
+0.38 21st February 2009
+
+ * Fixed typo in BerkleyDB.pod that broke t/pod.t
+
+0.37 18th February 2009
+
+ * Included CDS section to the pod.
+
+ * Various documentation patches from RT#42243
+
+0.36 30th September 2008
+
+ * Added support for $ENV->log_get_config and $ENV->log_set_config.
+ Patch supplied by Yuval Kogman (#39651 rt.cpan.org)
+
+0.35 22nd September 2008
+
+ * Added a combination of independent patches from Claes Jakobsson
+ and Yuval Kogman (#38896 rt.cpan.org) to allow multi-key return
+ from a secondard database.
+
+ * Added support for sequences. Initial patch from Claes Jakobsson.
+
+ * Get associate to use a transaction if one is specified.
+ #5855 from rt.cpan.org
+
+ * Finish transition of test harness to use Test::More
+
+0.34 27th March 2008
+
+ * Updates to support building with Berkeley DB version 4.7
+
+ * Typo in #ifdef for ThreadCount support. Spotted by Mark Hindley
+
+ * Updated dbinfo
+
+0.33 17th January 2008
+
+ * Added failchk, set_isalive, lock_stat_print & mutex_stat_print.
+ Patch provided by Thomas Busch.
+
+0.32 10th July 2007
+
+ * Updates to support Berkeley DB 4.6
+
+ * Remove all global static data from BerkeleyDB.xs.
+
+0.31 15th Oct 2006
+
+ * Fixed DB_GET_BOTH. Tnanks to Thomas Drugeon for spotting the typo
+ in typemap and supplying a regression test for this fix.
+
+0.30 11th Sept 2006
+
+ * Fixed queue test harness for Berkeley DB 4.5 compliance
+
+ * Added $env->lsn_reset, $txn->set_timeout, $env->set_timeout &
+ $env->get_timeout, $txn->set_tx_max, $txn->get_tx_max
+
+0.29 2nd July 2006
+
+ * Fixes for cursor get from secondary where primary os recno.
+
+ * Added db_compact
+
+0.28 11th June 2006
+
+ * Fixes for secondary where primary is recno.
+
+ * GET_BOTH_RANGE wasn't working. It is now.
+
+ * Added FreeBSD hints to README - patch supplied by David Landgren
+ in #17675 from rt.cpan.org
+
+0.27 1st Novemver 2005
+
+ * Added support for Berkeley DB 4.4
+
+ * Fixed secondary key issue with recno databases
+
+ * Added libscan to Makefile.PL
+
+ * Fixed a problem in t/subdb.t that meant it hung on Win32.
+
+ * The logic for set_mutexlocks was inverted when using Berkeley DB 4.x
+ Bug spotted by Zefram <zefram@fysh.org>
+
+ * Transactional rename/remove added.
+ Patch supplied by Zefram <zefram@fysh.org>
+
+
+0.26 10th October 2004
+
+ * Changed to allow Building with Berkeley DB 4.3
+
+ * added cds_lock and associated methods as a convenience to allow
+ safe updaing of database records when using Berkeley DB CDS mode.
+
+ * added t/cds.t and t/pod.t
+
+ * Modified the test suite to use "-ErrFile => *STDOUT" where
+ possible. This will make it easier to diagnose build issues.
+
+ * -Errfile will now accept a filehandle as well as a filename
+ This means that -ErrFile => *STDOUT will get all extended error
+ messages displayed directly on screen.
+
+ * Added support for set_shm_key & get_shm_key.
+
+ * Patch from Mark Jason Dominus to add a better error message
+ when an odd number of parameters are passed to ParseParameters.
+
+ * fixed off-by-one error in my_strdup
+
+ * Fixed a problem with push, pop, shift & unshift with Queue &
+ Recno when used in CDS mode. These methods were not using
+ a write cursor behind the scenes.
+ Problem reported by Pavel Hlavnicka.
+
+0.25 1st November 2003
+
+ * Minor update to dbinfo
+
+ * Fixed a bug in the test harnesses that is only apparent in
+ perl 5.8.2. Original patch courtesy of Michael Schwern.
+
+0.24 27th September 2003
+
+ * Mentioned comp.databases.berkeley-db in README
+
+ * Builds with Berkeley DB 4.2
+
+ * The return type for db->db_fd was wrongly set at DualType -
+ should be int.
+
+0.23 15th June 2003
+
+ * Fixed problem where a secondary index would use the same
+ compare callback as the primary key, regardless of what was
+ defined for the secondary index.
+ Problem spotted by Dave Tallman.
+
+ * Also fixed a problem with the associate callback. If the value
+ for the secondary key was not a string, the secondary key was
+ being set incorrectly. This is now fixed.
+
+ * When built with Berkeley DB 3.2 or better, all callbacks now use
+ the BackRef pointer instead of the global CurrentDB. This was
+ done partially to fix the secondary index problem, above.
+
+ * The test harness was failing under cygwin. Now fixed.
+
+ * Previous release broke TRACE. Fixed.
+
+0.22 17th May 2003
+
+ * win32 problem with open macro fixed.
+
+0.21 12th May 2003
+
+ * adding support for env->set_flags
+ * adding recursion detection
+ * win32 problem with rename fixed.
+ * problem with sub-database name in Recno & Queue fixed.
+ * fixed the mldbm.t test harness to work with perl 5.8.0
+ * added a note about not using a network drive when running the
+ test harness.
+ * fixed c_pget
+ * added BerkeleyDB::Env::DB_ENV method
+ * added support for encryption
+ * the dbinfo script will now indicate if the database is encrypted
+ * The CLEAR method is now CDB safe.
+
+0.20 2nd September 2002
+
+ * More support for building with Berkeley DB 4.1.x
+ * db->get & db->pget used the wrong output macro for DBM filters
+ bug spotted by Aaron Ross.
+ * db_join didn't keep a reference to the cursors it was joining.
+ Spotted by Winton Davies.
+
+0.19 5th June 2002
+ * Removed the targets that used mkconsts from Makefile.PL. They relied
+ on a module that is not available in all versions of Perl.
+ * added support for env->set_verbose
+ * added support for db->truncate
+ * added support for db->rename via BerkeleyDB::db_rename
+ * added support for db->verify via BerkeleyDB::db_verify
+ * added support for db->associate, db->pget & cursor->c_pget
+ * Builds with Berkeley DB 4.1.x
+
+
+0.18 6th January 2002
+ * Dropped support for ErrFile as a file handle. It was proving too
+ difficult to get at the underlying FILE * in XS.
+ Reported by Jonas Smedegaard (Debian powerpc) & Kenneth Olwing (Win32)
+ * Fixed problem with abort macro in XSUB.h clashing with txn abort
+ method in Berkeley DB 4.x -- patch supplied by Kenneth Olwing.
+ * DB->set_alloc was getting called too late in BerkeleyDB.xs.
+ This was causing problems with ActivePerl -- problem reported
+ by Kenneth Olwing.
+ * When opening a queue, the Len proprty set the DB_PAD flag.
+ Should have been DB_FIXEDLEN. Fix provided by Kenneth Olwing.
+ * Test harness fixes from Kenneth Olwing.
+
+0.17 23 September 2001
+ * Fixed a bug in BerkeleyDB::Recno - reported by Niklas Paulsson.
+ * Added log_archive - patch supplied by Benjamin Holzman
+ * Added txn_discard
+ * Builds with Berkeley DB 4.0.x
+
+0.16 1 August 2001
+ * added support for Berkeley DB 3.3.x (but no support for any of the
+ new features just yet)
+
+0.15 26 April 2001
+ * Fixed a bug in the processing of the flags options in
+ db_key_range.
+ * added support for set_lg_max & set_lg_bsize
+ * allow DB_TMP_DIR and DB_TEMP_DIR
+ * the -Filename parameter to BerkeleyDB::Queue didn't work.
+ * added symbol DB_CONSUME_WAIT
+
+0.14 21st January 2001
+ * Silenced the warnings when build with a 64-bit Perl.
+ * Can now build with DB 3.2.3h (part of MySQL). The test harness
+ takes an age to do the queue test, but it does eventually pass.
+ * Mentioned the problems that occur when perl is built with sfio.
+
+0.13 15th January 2001
+ * Added support to allow this module to build with Berkeley DB 3.2
+ * Updated dbinfo to support Berkeley DB 3.1 & 3.2 file format
+ changes.
+ * Documented the Solaris 2.7 core dump problem in README.
+ * Tidied up the test harness to fix a problem on Solaris where the
+ "fred" directory wasn't being deleted when it should have been.
+ * two calls to "open" clashed with a win32 macro.
+ * size argument for hash_cb is different for Berkeley DB 3.x
+ * Documented the issue of building on Linux.
+ * Added -Server, -CacheSize & -LockDetect options
+ [original patch supplied by Graham Barr]
+ * Added support for set_mutexlocks, c_count, set_q_extentsize,
+ key_range, c_dup
+ * Dropped the "attempted to close a Cursor with an open transaction"
+ error in c_close. The correct behaviour is that the cursor
+ should be closed before committing/aborting the transaction.
+
+0.12 2nd August 2000
+ * Serious bug with get fixed. Spotted by Sleepycat.
+ * Added hints file for Solaris & Irix (courtesy of Albert Chin-A-Young)
+
+0.11 4th June 2000
+ * When built with Berkeley Db 3.x there can be a clash with the close
+ macro.
+ * Typo in the definition of DB_WRITECURSOR
+ * The flags parameter wasn't getting sent to db_cursor
+ * Plugged small memory leak in db_cursor (DESTROY wasn't freeing
+ memory)
+ * Can be built with Berkeley DB 3.1
+
+0.10 8th December 1999
+ * The DESTROY method was missing for BerkeleyDB::Env. This resulted in
+ a memory leak. Fixed.
+ * If opening an environment or database failed, there was a small
+ memory leak. This has been fixed.
+ * A thread-enabled Perl it could core when a database was closed.
+ Problem traced to the strdup function.
+
+0.09 29th November 1999
+ * the queue.t & subdb.t test harnesses were outputting a few
+ spurious warnings. This has been fixed.
+
+0.08 28nd November 1999
+ * More documentation updates
+ * Changed reference to files in /tmp in examples.t
+ * Fixed a typo in softCrash that caused problems when building
+ with a thread-enabled Perl.
+ * BerkeleyDB::Error wasn't initialised properly.
+ * ANSI-ified all the static C functions in BerkeleyDB.xs
+ * Added support for the following DB 3.x features:
+ + The Queue database type
+ + db_remove
+ + subdatabases
+ + db_stat for Hash & Queue
+
+0.07 21st September 1999
+ * Numerous small bug fixes.
+ * Added support for sorting duplicate values DB_DUPSORT.
+ * Added support for DB_GET_BOTH & DB_NEXT_DUP.
+ * Added get_dup (from DB_File).
+ * beefed up the documentation.
+ * Forgot to add the DB_INIT_CDB in BerkeleyDB.pm in previous release.
+ * Merged the DBM Filter code from DB_File into BerkeleyDB.
+ * Fixed a nasty bug where a closed transaction was still used with
+ with dp_put, db_get etc.
+ * Added logic to gracefully close everything whenever a fatal error
+ happens. Previously the plug was just pulled.
+ * It is now a fatal error to explicitly close an environment if there
+ is still an open database; a database when there are open cursors or
+ an open transaction; and a cursor if there is an open transaction.
+ Using object destruction doesn't have this issue, as object
+ references will ensure everything gets closed in the correct order.
+ * The BOOT code now checks that the version of db.h & libdb are the
+ same - this seems to be a common problem on Linux.
+ * MLDBM support added.
+ * Support for the new join cursor added.
+ * Builds with Berkeley DB 3.x
+ * Updated dbinfo for Berkeley DB 3.x file formats.
+ * Deprecated the TxnMgr class. As with Berkeley DB version 3,
+ txn_begin etc are now accessed via the environment object.
+
+0.06 19 December 1998
+ * Minor modifications to get the module to build with DB 2.6.x
+ * Added support for DB 2.6.x's Concurrent Access Method, DB_INIT_CDB.
+
+0.05 9 November 1998
+ * Added a note to README about how to build Berkeley DB 2.x
+ when using HP-UX.
+ * Minor modifications to get the module to build with DB 2.5.x
+
+0.04 19 May 1998
+ * Define DEFSV & SAVE_DEFSV if not already defined. This allows
+ the module to be built with Perl 5.004_04.
+
+0.03 5 May 1998
+ * fixed db_get with DB_SET_RECNO
+ * fixed c_get with DB_SET_RECNO and DB_GET_RECNO
+ * implemented BerkeleyDB::Unknown
+ * implemented BerkeleyDB::Recno, including push, pop etc
+ modified the txn support.
+
+0.02 30 October 1997
+ * renamed module to BerkeleyDB
+ * fixed a few bugs & added more tests
+
+0.01 23 October 1997
+ * first alpha release as BerkDB.
+
diff --git a/lang/perl/BerkeleyDB/MANIFEST b/lang/perl/BerkeleyDB/MANIFEST
new file mode 100644
index 00000000..ccc1ce91
--- /dev/null
+++ b/lang/perl/BerkeleyDB/MANIFEST
@@ -0,0 +1,71 @@
+BerkeleyDB.pm
+BerkeleyDB.pod
+BerkeleyDB.pod.P
+BerkeleyDB.xs
+BerkeleyDB/Btree.pm
+BerkeleyDB/Hash.pm
+Changes
+config.in
+constants.h
+constants.xs
+dbinfo
+hints/dec_osf.pl
+hints/solaris.pl
+hints/irix_6_5.pl
+Makefile.PL
+MANIFEST
+mkconsts.pl
+mkpod
+ppport.h
+README
+t/btree.t
+t/cds.t
+t/db-3.0.t
+t/db-3.1.t
+t/db-3.2.t
+t/db-3.3.t
+t/db-4.x.t
+t/db-4.3.t
+t/db-4.4.t
+t/db-4.6.t
+t/db-4.7.t
+t/db-4.8.t
+t/destroy.t
+t/encode.t
+t/encrypt.t
+t/env.t
+t/examples.t
+t/examples.t.T
+t/examples3.t
+t/examples3.t.T
+t/filter.t
+t/hash.t
+t/heap.t
+t/join.t
+t/mldbm.t
+t/pod.t
+t/queue.t
+t/recno.t
+t/sequence.t
+t/strict.t
+t/subdb.t
+t/txn.t
+t/unknown.t
+t/util.pm
+t/Test/More.pm
+t/Test/Builder.pm
+Todo
+typemap
+patches/5.004
+patches/5.004_01
+patches/5.004_02
+patches/5.004_03
+patches/5.004_04
+patches/5.004_05
+patches/5.005
+patches/5.005_01
+patches/5.005_02
+patches/5.005_03
+patches/5.6.0
+scan.pl
+META.yml Module meta-data (added by MakeMaker)
diff --git a/lang/perl/BerkeleyDB/META.yml b/lang/perl/BerkeleyDB/META.yml
new file mode 100644
index 00000000..aacfed37
--- /dev/null
+++ b/lang/perl/BerkeleyDB/META.yml
@@ -0,0 +1,21 @@
+--- #YAML:1.0
+name: BerkeleyDB
+version: 0.50
+abstract: Perl extension for Berkeley DB version 2, 3, 4 or 5
+author:
+ - Paul Marquess <pmqs@cpan.org>
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires: {}
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.57_05
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
diff --git a/lang/perl/BerkeleyDB/Makefile.PL b/lang/perl/BerkeleyDB/Makefile.PL
new file mode 100644
index 00000000..7d678523
--- /dev/null
+++ b/lang/perl/BerkeleyDB/Makefile.PL
@@ -0,0 +1,152 @@
+#! perl -w
+
+# It should not be necessary to edit this file. The configuration for
+# BerkeleyDB is controlled from the file config.in
+
+
+BEGIN { die "BerkeleyDB needs Perl 5.004_04 or greater" if $] < 5.004_04 ; }
+
+use strict ;
+use ExtUtils::MakeMaker ;
+use Config ;
+
+# Check for the presence of sfio
+if ($Config{'d_sfio'}) {
+ print <<EOM;
+
+WARNING: Perl seems to have been built with SFIO support enabled.
+ Please read the SFIO Notes in the README file.
+
+EOM
+}
+
+my $LIB_DIR ;
+my $INC_DIR ;
+my $DB_NAME ;
+my $LIBS ;
+
+ParseCONFIG() ;
+
+if (defined $DB_NAME)
+ { $LIBS = $DB_NAME }
+else {
+ if ($^O eq 'MSWin32')
+ { $LIBS = '-llibdb' }
+ elsif ($^O =~ /aix/i ) {
+ $LIBS .= '-ldb -lpthread ';
+ if ($Config{'cc'} eq 'gcc' && $Config{'osvers'} eq '5.1')
+ { $LIBS .= '-lgcc_s' }
+ }
+ else
+ { $LIBS = '-ldb' }
+}
+
+# OS2 is a special case, so check for it now.
+my $OS2 = "" ;
+$OS2 = "-DOS2" if $^O eq 'os2' ;
+
+my $WALL = '';
+#$WALL = ' -Wall ' if $Config{'cc'} =~ /gcc/ ;
+
+
+WriteMakefile(
+ NAME => 'BerkeleyDB',
+ LIBS => ["-L${LIB_DIR} $LIBS"],
+ #MAN3PODS => {}, # Pods will be built by installman.
+ INC => "-I$INC_DIR",
+ VERSION_FROM => 'BerkeleyDB.pm',
+ XSPROTOARG => '-noprototypes',
+ DEFINE => "$OS2 $WALL",
+ #'macro' => { INSTALLDIRS => 'perl' },
+ 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'},
+ ($] >= 5.005
+ ? (ABSTRACT_FROM => 'BerkeleyDB.pod',
+ AUTHOR => 'Paul Marquess <pmqs@cpan.org>')
+ : ()
+ ),
+ ((ExtUtils::MakeMaker->VERSION() gt '6.30')
+ ? ('LICENSE' => 'perl')
+ : ()
+ ),
+
+ );
+
+
+sub MY::libscan
+{
+ my $self = shift ;
+ my $path = shift ;
+
+ return undef
+ if $path =~ /(~|\.bak)$/ ||
+ $path =~ /^\..*\.swp$/ ;
+
+ return $path;
+}
+
+
+sub MY::postamble {
+ '
+$(NAME).pod: $(NAME).pod.P t/examples.t.T t/examples3.t.T mkpod
+ perl ./mkpod
+
+$(NAME).xs: typemap
+ $(TOUCH) $(NAME).xs
+
+Makefile: config.in
+
+
+' ;
+}
+
+sub ParseCONFIG
+{
+ my ($k, $v) ;
+ my @badkey = () ;
+ my %Info = () ;
+ my @Options = qw( INCLUDE LIB DBNAME ) ;
+ my %ValidOption = map {$_, 1} @Options ;
+ my %Parsed = %ValidOption ;
+ my $CONFIG = 'config.in' ;
+
+ print "Parsing $CONFIG...\n" ;
+
+ # DBNAME is optional, so pretend it has been parsed.
+ delete $Parsed{'DBNAME'} ;
+
+ open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ;
+ while (<F>) {
+ s/^\s*|\s*$//g ;
+ next if /^\s*$/ or /^\s*#/ ;
+ s/\s*#\s*$// ;
+
+ ($k, $v) = split(/\s+=\s+/, $_, 2) ;
+ $k = uc $k ;
+ if ($ValidOption{$k}) {
+ delete $Parsed{$k} ;
+ $Info{$k} = $v ;
+ }
+ else {
+ push(@badkey, $k) ;
+ }
+ }
+ close F ;
+
+ print "Unknown keys in $CONFIG ignored [@badkey]\n"
+ if @badkey ;
+
+ # check parsed values
+ my @missing = () ;
+ die "The following keys are missing from $CONFIG file: [@missing]\n"
+ if @missing = keys %Parsed ;
+
+ $INC_DIR = $ENV{'BERKELEYDB_INCLUDE'} || $Info{'INCLUDE'} ;
+ $LIB_DIR = $ENV{'BERKELEYDB_LIB'} || $Info{'LIB'} ;
+ $DB_NAME = $ENV{BERKELEYDB_NAME} || $Info{'DBNAME'} ;
+ #$DB_NAME = $ENV{} || $Info{'DBNAME'} if defined $Info{'DBNAME'} ;
+
+ print "Looks Good.\n" ;
+
+}
+
+# end of file Makefile.PL
diff --git a/lang/perl/BerkeleyDB/README b/lang/perl/BerkeleyDB/README
new file mode 100644
index 00000000..26da9abd
--- /dev/null
+++ b/lang/perl/BerkeleyDB/README
@@ -0,0 +1,672 @@
+ BerkeleyDB
+
+ Version 0.50
+
+ 10th December 2011
+
+
+ Copyright (c) 1997-2011 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.
+
+
+DESCRIPTION
+-----------
+
+BerkeleyDB is a module which allows Perl programs to make use of the
+facilities provided by Berkeley DB version 2 or greater. (Note: if
+you want to use version 1 of Berkeley DB with Perl you need the DB_File
+module).
+
+Berkeley DB is a C library which provides a consistent interface to a
+number of database formats. BerkeleyDB provides an interface to all
+four of the database types (hash, btree, queue and recno) currently
+supported by Berkeley DB.
+
+For further details see the documentation in the file BerkeleyDB.pod.
+
+PREREQUISITES
+-------------
+
+Before you can build BerkeleyDB you need to have the following
+installed on your system:
+
+ * To run the test harness for this module, you must make sure that the
+ directory where you have untarred this module is NOT a network
+ drive, e.g. NFS or AFS.
+
+ * Perl 5.00 or greater.
+
+ * Berkeley DB Version 2.6.4 or greater
+
+ The official web site for Berkeley DB is
+
+ http://www.oracle.com/technology/products/berkeley-db/db/index.html
+
+ The latest version of Berkeley DB is always available there. It
+ is recommended that you use the most recent version available.
+
+ The one exception to this advice is where you want to use BerkeleyDB
+ to access database files created by a third-party application,
+ like Sendmail. In these cases you must build BerkeleyDB with a
+ compatible version of Berkeley DB.
+
+
+BUILDING THE MODULE
+-------------------
+
+Assuming you have met all the prerequisites, building the module should
+be relatively straightforward.
+
+Step 1 : If you are running Solaris 2.5, 2.7 or HP-UX 10 read either
+ the Solaris Notes or HP-UX Notes sections below.
+ If you are running Linux please read the Linux Notes section
+ before proceeding.
+ If you are running FreeBSD read the FreeBSD Notes section
+ below.
+
+
+Step 2 : Edit the file config.in to suit you local installation.
+ Instructions are given in the file.
+
+Step 3 : Build and test the module using this sequence of commands:
+
+ perl Makefile.PL
+ make
+ make test
+
+INSTALLATION
+------------
+
+ make install
+
+TROUBLESHOOTING
+===============
+
+Here are some of the problems that people encounter when building BerkeleyDB.
+
+Missing db.h or libdb.a
+-----------------------
+
+If you get an error like this:
+
+ cc -c -I./libraries/ -Dbool=char -DHAS_BOOL -I/usr/local/include -O2
+ -DVERSION=\"0.07\" -DXS_VERSION=\"0.07\" -fpic
+ -I/usr/local/lib/perl5/5.00503/i586-linux/CORE BerkeleyDB.c
+ BerkeleyDB.xs:52: db.h: No such file or directory
+
+or this:
+
+ cc -c -I./libraries/2.7.5 -Dbool=char -DHAS_BOOL -I/usr/local/include -O2
+ -DVERSION=\"0.07\" -DXS_VERSION=\"0.07\" -fpic
+ -I/usr/local/lib/perl5/5.00503/i586-linux/CORE BerkeleyDB.c
+ LD_RUN_PATH="/lib" cc -o blib/arch/auto/BerkeleyDB/BerkeleyDB.so -shared
+ -L/usr/local/lib BerkeleyDB.o
+ -L/home/paul/perl/ext/BerkDB/BerkeleyDB/libraries -ldb
+ ld: cannot open -ldb: No such file or directory
+
+This symptom can imply:
+
+ 1. You don't have Berkeley DB installed on your system at all.
+ Solution: get & install Berkeley DB.
+
+ 2. You do have Berkeley DB installed, but it isn't in a standard place.
+ Solution: Edit config.in and set the LIB and INCLUDE variables to point
+ to the directories where libdb.a and db.h are installed.
+
+#error db.h is not for Berkeley DB at all.
+------------------------------------------
+
+If you get the error above when building this module it means that there
+is a file called "db.h" on your system that isn't the one that comes
+with Berkeley DB.
+
+Options:
+
+ 1. You don't have Berkeley DB installed on your system at all.
+ Solution: get & install Berkeley DB.
+
+ 2. Edit config.in and make sure the INCLUDE variable points to the
+ directory where the Berkeley DB file db.h is installed.
+
+ 3. If option 2 doesn't work, try tempoarily renaming the db.h file
+ that is causing the error.
+
+#error db.h is for Berkeley DB 1.x - need at least Berkeley DB 2.6.4
+--------------------------------------------------------------------
+
+The error above will occur if there is a copy of the Berkeley DB 1.x
+file db.h on your system.
+
+This error will happen when
+
+ 1. you only have Berkeley DB version 1 on your system.
+ Solution: get & install a newer version of Berkeley DB.
+
+ 2. you have both version 1 and a later version of Berkeley DB
+ installed on your system. When building BerkeleyDB it attempts to
+ use the db.h for Berkeley DB version 1.
+ Solution: Edit config.in and set the LIB and INCLUDE variables
+ to point to the directories where libdb.a and db.h are
+ installed.
+
+
+#error db.h is for Berkeley DB 2.0-2.5 - need at least Berkeley DB 2.6.4
+------------------------------------------------------------------------
+
+The error above will occur if there is a copy of the the file db.h for
+Berkeley DB 2.0 to 2.5 on your system.
+
+This symptom can imply:
+
+ 1. You don't have a new enough version of Berkeley DB.
+ Solution: get & install a newer version of Berkeley DB.
+
+ 2. You have the correct version of Berkeley DB installed, but it isn't
+ in a standard place.
+ Solution: Edit config.in and set the LIB and INCLUDE variables
+ to point to the directories where libdb.a and db.h are
+ installed.
+
+Undefined Symbol: txn_stat
+--------------------------
+
+BerkeleyDB seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00503
+ -Iblib/arch -Iblib/lib -I/usr/local/lib/perl5/5.00503/i586-linux
+ -I/usr/local/lib/perl5/5.00503 -e 'use Test::Harness qw(&runtests $verbose);
+ $verbose=0; runtests @ARGV;' t/*.t
+ t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for
+ module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so:
+ undefined symbol: txn_stat
+ at /usr/local/lib/perl5/5.00503/i586-linux/DynaLoader.pm line 169.
+ ...
+
+This error usually happens when you have both version 1 and a newer version
+of Berkeley DB installed on your system. BerkeleyDB attempts
+to build using the db.h for Berkeley DB version 2/3/4 and the version 1
+library. Unfortunately the two versions aren't compatible with each
+other. BerkeleyDB can only be built with Berkeley DB version 2, 3 or 4.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want BerkeleyDB to use.
+
+Undefined Symbol: db_appinit
+----------------------------
+
+BerkeleyDB seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00561 -Iblib/arch
+ -Iblib/lib -I/home/paul/perl/install/5.005_61/lib/5.00561/i586-linux
+ -I/home/paul/perl/install/5.005_61/lib/5.00561 -e 'use Test::Harness
+ qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t
+ t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for
+ module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so:
+ undefined symbol: db_appinit
+ at /home/paul/perl/install/5.005_61/lib/5.00561/i586-linux/DynaLoader.pm
+ ...
+
+
+This error usually happens when you have both version 2 and version
+3 of Berkeley DB installed on your system and BerkeleyDB attempts
+to build using the db.h for Berkeley DB version 2 and the version 3
+library. Unfortunately the two versions aren't compatible with each
+other.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want BerkeleyDB to use.
+
+Undefined Symbol: db_create
+---------------------------
+
+BerkeleyDB seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00561 -Iblib/arch
+ -Iblib/lib -I/home/paul/perl/install/5.005_61/lib/5.00561/i586-linux
+ -I/home/paul/perl/install/5.005_61/lib/5.00561 -e 'use Test::Harness
+ qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t
+ t/btree.............Can't load 'blib/arch/auto/BerkeleyDB/BerkeleyDB.so' for
+ module BerkeleyDB: blib/arch/auto/BerkeleyDB/BerkeleyDB.so:
+ undefined symbol: db_create
+ at /home/paul/perl/install/5.005_61/lib/5.00561/i586-linux/DynaLoader.pm
+ ...
+
+This error usually happens when you have both version 2 and version
+3 of Berkeley DB installed on your system and BerkeleyDB attempts
+to build using the db.h for Berkeley DB version 3 and the version 2
+library. Unfortunately the two versions aren't compatible with each
+other.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want BerkeleyDB to use.
+
+
+Incompatible versions of db.h and libdb
+---------------------------------------
+
+BerkeleyDB seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00503
+ -Iblib/arch -Iblib/lib -I/usr/local/lib/perl5/5.00503/i586-linux
+ -I/usr/local/lib/perl5/5.00503 -e 'use Test::Harness qw(&runtests $verbose);
+ $verbose=0; runtests @ARGV;' t/*.t
+ t/btree.............
+ BerkeleyDB needs compatible versions of libdb & db.h
+ you have db.h version 2.6.4 and libdb version 2.7.5
+ BEGIN failed--compilation aborted at t/btree.t line 25.
+ dubious
+ Test returned status 255 (wstat 65280, 0xff00)
+ ...
+
+Another variation on the theme of having two versions of Berkeley DB on
+your system.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want BerkeleyDB to use.
+ If you are running Linux, please read the Linux Notes section below.
+
+
+
+Solaris build fails with "language optional software package not installed"
+---------------------------------------------------------------------------
+
+If you are trying to build this module under Solaris and you get an
+error message like this
+
+ /usr/ucb/cc: language optional software package not installed
+
+it means that Perl cannot find the C compiler on your system. The cryptic
+message is just Sun's way of telling you that you haven't bought their
+C compiler.
+
+When you build a Perl module that needs a C compiler, the Perl build
+system tries to use the same C compiler that was used to build perl
+itself. In this case your Perl binary was built with a C compiler that
+lived in /usr/ucb.
+
+To continue with building this module, you need to get a C compiler,
+or tell Perl where your C compiler is, if you already have one.
+
+Assuming you have now got a C compiler, what you do next will be dependant
+on what C compiler you have installed. If you have just installed Sun's
+C compiler, you shouldn't have to do anything. Just try rebuilding
+this module.
+
+If you have installed another C compiler, say gcc, you have to tell perl
+how to use it instead of /usr/ucb/cc.
+
+This set of options seems to work if you want to use gcc. Your mileage
+may vary.
+
+ perl Makefile.PL CC=gcc CCCDLFLAGS=-fPIC OPTIMIZE=" "
+ make test
+
+If that doesn't work for you, it's time to make changes to the Makefile
+by hand. Good luck!
+
+
+
+Solaris build fails with "gcc: unrecognized option `-KPIC'"
+-----------------------------------------------------------
+
+You are running Solaris and you get an error like this when you try to
+build this Perl module
+
+ gcc: unrecognized option `-KPIC'
+
+This symptom usually means that you are using a Perl binary that has been
+built with the Sun C compiler, but you are using gcc to build this module.
+
+When Perl builds modules that need a C compiler, it will attempt to use
+the same C compiler and command line options that was used to build perl
+itself. In this case "-KPIC" is a valid option for the Sun C compiler,
+but not for gcc. The equivalent option for gcc is "-fPIC".
+
+The solution is either:
+
+ 1. Build both Perl and this module with the same C compiler, either
+ by using the Sun C compiler for both or gcc for both.
+
+ 2. Try generating the Makefile for this module like this perl
+
+ perl Makefile.PL CC=gcc CCCDLFLAGS=-fPIC OPTIMIZE=" " LD=gcc
+ make test
+
+ This second option seems to work when mixing a Perl binary built
+ with the Sun C compiler and this module built with gcc. Your
+ mileage may vary.
+
+
+
+Network Drive
+-------------
+
+BerkeleyDB seems to have built correctly, but you get a series of errors
+like this when you run the test harness:
+
+
+t/btree........NOK 178Can't call method "txn_begin" on an undefined value at t/btree.t line 637.
+t/btree........dubious
+ Test returned status 11 (wstat 2816, 0xb00)
+DIED. FAILED tests 28, 178-244
+ Failed 68/244 tests, 72.13% okay
+t/db-3.0.......NOK 2Can't call method "set_mutexlocks" on an undefined value at t/db-3.0.t line 39.
+t/db-3.0.......dubious
+ Test returned status 11 (wstat 2816, 0xb00)
+DIED. FAILED tests 2-14
+ Failed 13/14 tests, 7.14% okay
+t/db-3.1.......ok
+t/db-3.2.......NOK 5Can't call method "set_flags" on an undefined value at t/db-3.2.t line 62.
+t/db-3.2.......dubious
+ Test returned status 11 (wstat 2816, 0xb00)
+DIED. FAILED tests 3, 5-6
+ Failed 3/6 tests, 50.00% okay
+t/db-3.3.......ok
+
+This pattern of errors happens if you have built the module in a directory
+that is network mounted (e.g. NFS ar AFS).
+
+The solution is to use a local drive. Berkeley DB doesn't support
+network drives.
+
+
+Berkeley DB library configured to support only DB_PRIVATE environments
+----------------------------------------------------------------------
+
+BerkeleyDB seems to have built correctly, but you get a series of errors
+like this when you run the test harness:
+
+ t/btree........ok 27/244
+ # : Berkeley DB library configured to support only DB_PRIVATE environments
+ t/btree........ok 177/244
+ # : Berkeley DB library configured to support only DB_PRIVATE environments
+ t/btree........NOK 178Can't call method "txn_begin" on an undefined value at t/btree.t line 638.
+ t/btree........dubious
+ Test returned status 2 (wstat 512, 0x200)
+ Scalar found where operator expected at (eval 153) line 1, near "'int' $__val"
+ (Missing operator before $__val?)
+ DIED. FAILED tests 28, 178-244
+ Failed 68/244 tests, 72.13% okay
+
+
+Some versions of Redhat Linux, and possibly some other Linux
+distributions, include a seriously restricted build of the
+Berkeley DB library that is incompatible with this module. See
+https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=91933 for an
+exhaustive discussion on the reasons for this.
+
+
+Solution:
+
+You will have to build a private copy of the Berkeley DB library and
+use it when building this Perl module.
+
+
+
+Linux Notes
+-----------
+
+Some versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library
+that has version 2.x of Berkeley DB linked into it. This makes it
+difficult to build this module with anything other than the version of
+Berkeley DB that shipped with your Linux release. If you do try to use
+a different version of Berkeley DB you will most likely get the error
+described in the "Incompatible versions of db.h and libdb" section of
+this file.
+
+To make matters worse, prior to Perl 5.6.1, the perl binary itself
+*always* included the Berkeley DB library.
+
+If you want to use a newer version of Berkeley DB with this module, the
+easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x
+(or better).
+
+There are two approaches you can use to get older versions of Perl to
+work with specific versions of Berkeley DB. Both have their advantages
+and disadvantages.
+
+The first approach will only work when you want to build a version of
+Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use
+Berkeley DB 2.x, you must use the next approach. This approach involves
+rebuilding your existing version of Perl after applying an unofficial
+patch. The "patches" directory in the this module's source distribution
+contains a number of patch files. There is one patch file for every
+stable version of Perl since 5.004. Apply the appropriate patch to your
+Perl source tree before re-building and installing Perl from scratch.
+For example, assuming you are in the top-level source directory for
+Perl 5.6.0, the command below will apply the necessary patch. Remember
+to replace the path shown below with one that points to this module's
+patches directory.
+
+ patch -p1 -N </path/to/BerkeleyDB/patches/5.6.0
+
+Now rebuild & install perl. You should now have a perl binary that can
+be used to build this module. Follow the instructions in "BUILDING THE
+MODULE", remembering to set the INCLUDE and LIB variables in config.in.
+
+
+The second approach will work with Berkeley DB 2.x or better.
+Start by building Berkeley DB as a shared library. This is from
+the Berkeley DB build instructions:
+
+ Building Shared Libraries for the GNU GCC compiler
+
+ If you're using gcc and there's no better shared library example for
+ your architecture, the following shared library build procedure will
+ probably work.
+
+ Add the -fpic option to the CFLAGS value in the Makefile.
+
+ Rebuild all of your .o files. This will create a Berkeley DB library
+ that contains .o files with PIC code. To build the shared library,
+ then take the following steps in the library build directory:
+
+ % mkdir tmp
+ % cd tmp
+ % ar xv ../libdb.a
+ % gcc -shared -o libdb.so *.o
+ % mv libdb.so ..
+ % cd ..
+ % rm -rf tmp
+
+ Note, you may have to change the gcc line depending on the
+ requirements of your system.
+
+ The file libdb.so is your shared library
+
+Once you have built libdb.so, you will need to store it somewhere safe.
+
+ cp libdb.so /usr/local/BerkeleyDB/lib
+
+If you now set the LD_PRELOAD environment variable to point to this
+shared library, Perl will use it instead of the version of Berkeley DB
+that shipped with your Linux distribution.
+
+ export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so
+
+Finally follow the instructions in "BUILDING THE MODULE" to build,
+test and install this module. Don't forget to set the INCLUDE and LIB
+variables in config.in.
+
+Remember, you will need to have the LD_PRELOAD variable set anytime you
+want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD
+permanently set it will affect ALL commands you execute. This may be a
+problem if you run any commands that access a database created by the
+version of Berkeley DB that shipped with your Linux distribution.
+
+
+
+Solaris 2.5 Notes
+-----------------
+
+If you are running Solaris 2.5, and you get this error when you run the
+BerkeleyDB test harness:
+
+ libc internal error: _rmutex_unlock: rmutex not held.
+
+you probably need to install a Sun patch. It has been reported that
+Sun patch 103187-25 (or later revisions) fixes this problem.
+
+To find out if you have the patch installed, the command "showrev -p"
+will display the patches that are currently installed on your system.
+
+
+Solaris 2.7 Notes
+-----------------
+
+If you are running Solaris 2.7 and all the tests in the test harness
+generate a core dump, try applying Sun patch 106980-09 (or better).
+
+To find out if you have the patch installed, the command "showrev -p"
+will display the patches that are currently installed on your system.
+
+
+HP-UX Notes
+-----------
+
+Some people running HP-UX 10 have reported getting an error like this
+when building this module with the native HP-UX compiler.
+
+ ld: (Warning) At least one PA 2.0 object file (BerkeleyDB.o) was detected.
+ The linked output may not run on a PA 1.x system.
+ ld: Invalid loader fixup for symbol "$000000A5".
+
+If this is the case for you, Berkeley DB needs to be recompiled with
+the +z or +Z option and the resulting library placed in a .sl file. The
+following steps should do the trick:
+
+ 1: Configure the Berkeley DB distribution with the +z or +Z C compiler
+ flag:
+
+ env "CFLAGS=+z" ../dist/configure ...
+
+ 2: Edit the Berkeley DB Makefile and change:
+
+ "libdb= libdb.a" to "libdb= libdb.sl".
+
+ 3: Build and install the Berkeley DB distribution as usual.
+
+
+FreeBSD Notes
+-------------
+
+On FreeBSD 4.x through 6.x, the default db.h is for version 1. The build
+will fail with an error similar to:
+
+BerkeleyDB.xs:74: #error db.h is from Berkeley DB 1.x - need at least
+Berkeley DB 2.6.4
+
+Later versions of Berkeley DB are usually installed from ports.
+The available versions can be found by running a find(1) command:
+
+ % find /usr/local/include -name 'db.h'
+ /usr/local/include/db3/db.h
+ /usr/local/include/db4/db.h
+ /usr/local/include/db41/db.h
+ /usr/local/include/db42/db.h
+ /usr/local/include/db43/db.h
+
+The desired version of the library must be specified on the command line or
+via the config.in file. Make sure both values point to the same version:
+
+ INCLUDE = /usr/local/include/db43
+ LIB = /usr/local/lib/db43
+
+
+
+
+FEEDBACK
+--------
+
+General feedback/questions/bug reports can be sent to me at pmqs@cpan.org.
+
+Alternatively, if you have Usenet access, you can try the
+comp.databases.berkeley-db or comp.lang.perl.modules groups.
+
+
+How to report a problem with BerkeleyDB.
+----------------------------------------
+
+To help me help you, I need of the following information:
+
+ 1. The version of Perl and the operating system name and version you
+ are running. The complete output from running "perl -V" will tell
+ me all I need to know.
+ If your perl does not understand the "-V" option is too old.
+ BerkeleyDB needs Perl version 5.004_04 or better.
+
+ 2. The version of BerkeleyDB you have. If you have successfully
+ installed BerkeleyDB, this one-liner will tell you:
+
+ perl -MBerkeleyDB -e 'print qq{BerkeleyDB ver $BerkeleyDB::VERSION\n}'
+
+ If you are running windows use this
+
+ perl -MBerkeleyDB -e "print qq{BerkeleyDB ver $BerkeleyDB::VERSION\n}"
+
+ If you haven't installed BerkeleyDB then search BerkeleyDB.pm for a
+ line like this:
+
+ $VERSION = "1.20" ;
+
+ 3. The version of Berkeley DB you have installed. If you have
+ successfully installed BerkeleyDB, this one-liner will tell you:
+
+ perl -MBerkeleyDB -e 'print BerkeleyDB::DB_VERSION_STRING.qq{\n}'
+
+ If you are running windows use this
+
+ perl -MBerkeleyDB -e "print BerkeleyDB::DB_VERSION_STRING.qq{\n}"
+
+ If you haven't installed BerkeleyDB then search db.h for a line
+ like this:
+
+ #define DB_VERSION_STRING
+
+ 4. If you are having problems building BerkeleyDB, send me a complete
+ log of what happened.
+
+ 5. Now the difficult one. If you think you have found a bug in
+ BerkeleyDB and you want me to fix it, you will *greatly* enhance
+ the chances of me being able to track it down by sending me a small
+ self-contained Perl script that illustrates the problem you are
+ encountering. Include a summary of what you think the problem is
+ and a log of what happens when you run the script, in case I can't
+ reproduce your problem on my system. If possible, don't have the
+ script dependent on an existing 20Meg database. If the script you
+ send me can create the database itself then that is preferred.
+
+ I realise that in some cases this is easier said than done, so if
+ you can only reproduce the problem in your existing script, then
+ you can post me that if you want. Just don't expect me to find your
+ problem in a hurry, or at all. :-)
+
+
+CHANGES
+-------
+
+See the Changes file.
+
+Paul Marquess <pmqs@cpan.org>
+
diff --git a/lang/perl/BerkeleyDB/Todo b/lang/perl/BerkeleyDB/Todo
new file mode 100644
index 00000000..12d53bcf
--- /dev/null
+++ b/lang/perl/BerkeleyDB/Todo
@@ -0,0 +1,57 @@
+
+ * Proper documentation.
+
+ * address or document the "close all cursors if you encounter an error"
+
+ * Change the $BerkeleyDB::Error to store the info in the db object,
+ if possible.
+
+ * $BerkeleyDB::db_version is documented. &db_version isn't.
+
+ * migrate perl code into the .xs file where necessary
+
+ * convert as many of the DB examples files to BerkeleyDB format.
+
+ * add a method to the DB object to allow access to the environment (if there
+ actually is one).
+
+
+Possibles
+
+ * use '~' magic to store the inner data.
+
+ * for the get stuff zap the value to undef if it doesn't find the
+ key. This may be more intuitive for those folks who are used with
+ the $hash{key} interface.
+
+ * Text interface? This can be done as via Recno
+
+ * allow recno to allow base offset for arrays to be either 0 or 1.
+
+ * when duplicate keys are enabled, allow db_put($key, [$val1, $val2,...])
+
+
+2.x -> 3.x Upgrade
+==================
+
+Environment Verbose
+Env->open mode
+DB cache size extra parameter
+DB->open subdatabases Done
+An empty environment causes DB->open to fail
+where is __db.001 coming from? db_remove seems to create it. Bug in 3.0.55
+Change db_strerror for 0 to ""? Done
+Queue Done
+db_stat for Hash & Queue Done
+No TxnMgr
+DB->remove
+ENV->remove
+ENV->set_verbose
+upgrade
+
+ $env = BerkeleyDB::Env::Create
+ $env = create BerkeleyDB::Env
+ $status = $env->open()
+
+ $db = BerkeleyDB::Hash::Create
+ $status = $db->open()
diff --git a/lang/perl/BerkeleyDB/config.in b/lang/perl/BerkeleyDB/config.in
new file mode 100644
index 00000000..3c37ea93
--- /dev/null
+++ b/lang/perl/BerkeleyDB/config.in
@@ -0,0 +1,45 @@
+# Filename: config.in
+#
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+
+# 1. Where is the file db.h?
+#
+# Change the path below to point to the directory where db.h is
+# installed on your system.
+
+#INCLUDE = /usr/local/include
+#INCLUDE = ../..
+INCLUDE = /usr/local/BerkeleyDB/include
+
+# 2. Where is libdb?
+#
+# Change the path below to point to the directory where libdb is
+# installed on your system.
+
+#LIB = /usr/local/lib
+#LIB = ../..
+LIB = /usr/local/BerkeleyDB/lib
+
+# 3. Is the library called libdb?
+#
+# If you have copies of both 1.x and 2.x Berkeley DB installed on
+# your system it can sometimes be tricky to make sure you are using
+# the correct one. Renaming one (or creating a symbolic link) to
+# include the version number of the library can help.
+#
+# For example, if you have Berkeley DB 2.6.4 you could rename the
+# Berkeley DB library from libdb.a to libdb-2.6.4.a and change the
+# DBNAME line below to look like this:
+#
+# DBNAME = -ldb-2.6.4
+#
+# Note: If you are building this module with Win32, -llibdb will be
+# used by default.
+#
+# If you have changed the name of the library, uncomment the line
+# below (by removing the leading #) and edit the line to use the name
+# you have picked.
+
+#DBNAME = -ldb-3.0
+
+# end of file config.in
diff --git a/lang/perl/BerkeleyDB/constants.h b/lang/perl/BerkeleyDB/constants.h
new file mode 100644
index 00000000..6f55ad4d
--- /dev/null
+++ b/lang/perl/BerkeleyDB/constants.h
@@ -0,0 +1,7112 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant_6 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_DUP DB_PAD DB_RMW DB_SET */
+ /* Offset 3 gives the best switch position. */
+ switch (name[3]) {
+ case 'D':
+ if (memEQ(name, "DB_DUP", 6)) {
+ /* ^ */
+#ifdef DB_DUP
+ *iv_return = DB_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_PAD", 6)) {
+ /* ^ */
+#ifdef DB_PAD
+ *iv_return = DB_PAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_RMW", 6)) {
+ /* ^ */
+#ifdef DB_RMW
+ *iv_return = DB_RMW;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_SET", 6)) {
+ /* ^ */
+#ifdef DB_SET
+ *iv_return = DB_SET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_7 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_EXCL DB_HASH DB_HEAP DB_LAST DB_NEXT DB_PREV */
+ /* Offset 3 gives the best switch position. */
+ switch (name[3]) {
+ case 'E':
+ if (memEQ(name, "DB_EXCL", 7)) {
+ /* ^ */
+#ifdef DB_EXCL
+ *iv_return = DB_EXCL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_HASH", 7)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_HASH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HEAP", 7)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_HEAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_LAST", 7)) {
+ /* ^ */
+#ifdef DB_LAST
+ *iv_return = DB_LAST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_NEXT", 7)) {
+ /* ^ */
+#ifdef DB_NEXT
+ *iv_return = DB_NEXT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_PREV", 7)) {
+ /* ^ */
+#ifdef DB_PREV
+ *iv_return = DB_PREV;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_8 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_AFTER DB_BTREE DB_FIRST DB_FLUSH DB_FORCE DB_QUEUE DB_RECNO DB_UNREF */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'E':
+ if (memEQ(name, "DB_RECNO", 8)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_RECNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_AFTER", 8)) {
+ /* ^ */
+#ifdef DB_AFTER
+ *iv_return = DB_AFTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_FIRST", 8)) {
+ /* ^ */
+#ifdef DB_FIRST
+ *iv_return = DB_FIRST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_FLUSH", 8)) {
+ /* ^ */
+#ifdef DB_FLUSH
+ *iv_return = DB_FLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_UNREF", 8)) {
+ /* ^ */
+#ifdef DB_UNREF
+ *iv_return = DB_UNREF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_FORCE", 8)) {
+ /* ^ */
+#ifdef DB_FORCE
+ *iv_return = DB_FORCE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_BTREE", 8)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_BTREE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_QUEUE", 8)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 3) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 55)
+ *iv_return = DB_QUEUE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_9 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_APPEND DB_BEFORE DB_CHKSUM DB_CLIENT DB_COMMIT DB_CREATE DB_CURLSN
+ DB_DIRECT DB_EXTENT DB_GETREC DB_LEGACY DB_NOCOPY DB_NOMMAP DB_NOSYNC
+ DB_RDONLY DB_RECNUM DB_THREAD DB_VERIFY LOGREC_DB LOGREC_OP */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case 'A':
+ if (memEQ(name, "DB_NOMMAP", 9)) {
+ /* ^ */
+#ifdef DB_NOMMAP
+ *iv_return = DB_NOMMAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_THREAD", 9)) {
+ /* ^ */
+#ifdef DB_THREAD
+ *iv_return = DB_THREAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_DIRECT", 9)) {
+ /* ^ */
+#ifdef DB_DIRECT
+ *iv_return = DB_DIRECT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LEGACY", 9)) {
+ /* ^ */
+#ifdef DB_LEGACY
+ *iv_return = DB_LEGACY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "LOGREC_DB", 9)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_GETREC", 9)) {
+ /* ^ */
+#ifdef DB_GETREC
+ *iv_return = DB_GETREC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_VERIFY", 9)) {
+ /* ^ */
+#ifdef DB_VERIFY
+ *iv_return = DB_VERIFY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_COMMIT", 9)) {
+ /* ^ */
+#ifdef DB_COMMIT
+ *iv_return = DB_COMMIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_RDONLY", 9)) {
+ /* ^ */
+#ifdef DB_RDONLY
+ *iv_return = DB_RDONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_APPEND", 9)) {
+ /* ^ */
+#ifdef DB_APPEND
+ *iv_return = DB_APPEND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_CLIENT", 9)) {
+ /* ^ */
+#ifdef DB_CLIENT
+ *iv_return = DB_CLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_EXTENT", 9)) {
+ /* ^ */
+#ifdef DB_EXTENT
+ *iv_return = DB_EXTENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOSYNC", 9)) {
+ /* ^ */
+#ifdef DB_NOSYNC
+ *iv_return = DB_NOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "LOGREC_OP", 9)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_OP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_NOCOPY", 9)) {
+ /* ^ */
+#ifdef DB_NOCOPY
+ *iv_return = DB_NOCOPY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_BEFORE", 9)) {
+ /* ^ */
+#ifdef DB_BEFORE
+ *iv_return = DB_BEFORE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_CURLSN", 9)) {
+ /* ^ */
+#ifdef DB_CURLSN
+ *iv_return = DB_CURLSN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_CREATE", 9)) {
+ /* ^ */
+#ifdef DB_CREATE
+ *iv_return = DB_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_CHKSUM", 9)) {
+ /* ^ */
+#ifdef DB_CHKSUM
+ *iv_return = DB_CHKSUM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RECNUM", 9)) {
+ /* ^ */
+#ifdef DB_RECNUM
+ *iv_return = DB_RECNUM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_10 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_CONSUME DB_CURRENT DB_DELETED DB_DUPSORT DB_ENCRYPT DB_ENV_CDB
+ DB_ENV_TXN DB_FAILCHK DB_INORDER DB_JOINENV DB_KEYLAST DB_NOERROR
+ DB_NOFLUSH DB_NOPANIC DB_OK_HASH DB_OK_HEAP DB_PRIVATE DB_PR_PAGE
+ DB_RECOVER DB_SALVAGE DB_SEQ_DEC DB_SEQ_INC DB_SET_LTE DB_TIMEOUT
+ DB_TXN_CKP DB_UNKNOWN DB_UPGRADE LOGREC_ARG LOGREC_DBT LOGREC_HDR */
+ /* Offset 8 gives the best switch position. */
+ switch (name[8]) {
+ case 'A':
+ if (memEQ(name, "DB_OK_HEAP", 10)) {
+ /* ^ */
+#ifdef DB_OK_HEAP
+ *iv_return = DB_OK_HEAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "LOGREC_DBT", 10)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_DBT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_ENV_CDB", 10)) {
+ /* ^ */
+#ifdef DB_ENV_CDB
+ *iv_return = DB_ENV_CDB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_UPGRADE", 10)) {
+ /* ^ */
+#ifdef DB_UPGRADE
+ *iv_return = DB_UPGRADE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_HDR", 10)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_HDR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_DELETED", 10)) {
+ /* ^ */
+#ifdef DB_DELETED
+ *iv_return = DB_DELETED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_INORDER", 10)) {
+ /* ^ */
+#ifdef DB_INORDER
+ *iv_return = DB_INORDER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RECOVER", 10)) {
+ /* ^ */
+#ifdef DB_RECOVER
+ *iv_return = DB_RECOVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQ_DEC", 10)) {
+ /* ^ */
+#ifdef DB_SEQ_DEC
+ *iv_return = DB_SEQ_DEC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_PR_PAGE", 10)) {
+ /* ^ */
+#ifdef DB_PR_PAGE
+ *iv_return = DB_PR_PAGE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SALVAGE", 10)) {
+ /* ^ */
+#ifdef DB_SALVAGE
+ *iv_return = DB_SALVAGE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_FAILCHK", 10)) {
+ /* ^ */
+#ifdef DB_FAILCHK
+ *iv_return = DB_FAILCHK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_NOPANIC", 10)) {
+ /* ^ */
+#ifdef DB_NOPANIC
+ *iv_return = DB_NOPANIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_TXN_CKP", 10)) {
+ /* ^ */
+#ifdef DB_TXN_CKP
+ *iv_return = DB_TXN_CKP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_CONSUME", 10)) {
+ /* ^ */
+#ifdef DB_CONSUME
+ *iv_return = DB_CONSUME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_CURRENT", 10)) {
+ /* ^ */
+#ifdef DB_CURRENT
+ *iv_return = DB_CURRENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_JOINENV", 10)) {
+ /* ^ */
+#ifdef DB_JOINENV
+ *iv_return = DB_JOINENV;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQ_INC", 10)) {
+ /* ^ */
+#ifdef DB_SEQ_INC
+ *iv_return = DB_SEQ_INC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_NOERROR", 10)) {
+ /* ^ */
+#ifdef DB_NOERROR
+ *iv_return = DB_NOERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_ENCRYPT", 10)) {
+ /* ^ */
+#ifdef DB_ENCRYPT
+ *iv_return = DB_ENCRYPT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_DUPSORT", 10)) {
+ /* ^ */
+#ifdef DB_DUPSORT
+ *iv_return = DB_DUPSORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_ARG", 10)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_ARG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_KEYLAST", 10)) {
+ /* ^ */
+#ifdef DB_KEYLAST
+ *iv_return = DB_KEYLAST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOFLUSH", 10)) {
+ /* ^ */
+#ifdef DB_NOFLUSH
+ *iv_return = DB_NOFLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OK_HASH", 10)) {
+ /* ^ */
+#ifdef DB_OK_HASH
+ *iv_return = DB_OK_HASH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_PRIVATE", 10)) {
+ /* ^ */
+#ifdef DB_PRIVATE
+ *iv_return = DB_PRIVATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SET_LTE", 10)) {
+ /* ^ */
+#ifdef DB_SET_LTE
+ *iv_return = DB_SET_LTE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_TIMEOUT", 10)) {
+ /* ^ */
+#ifdef DB_TIMEOUT
+ *iv_return = DB_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_UNKNOWN", 10)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_UNKNOWN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB_ENV_TXN", 10)) {
+ /* ^ */
+#ifdef DB_ENV_TXN
+ *iv_return = DB_ENV_TXN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB2_AM_EXCL DB_APP_INIT DB_ARCH_ABS DB_ARCH_LOG DB_DEGREE_2 DB_DSYNC_DB
+ DB_FILEOPEN DB_FIXEDLEN DB_GET_BOTH DB_GID_SIZE DB_INIT_CDB DB_INIT_LOG
+ DB_INIT_REP DB_INIT_TXN DB_KEYEMPTY DB_KEYEXIST DB_KEYFIRST DB_LOCKDOWN
+ DB_LOCK_GET DB_LOCK_PUT DB_LOGMAGIC DB_LOG_DISK DB_LOG_PERM DB_LOG_ZERO
+ DB_MEM_LOCK DB_MULTIPLE DB_NEXT_DUP DB_NOSERVER DB_NOTFOUND DB_OK_BTREE
+ DB_OK_QUEUE DB_OK_RECNO DB_POSITION DB_PREV_DUP DB_QAMMAGIC DB_REGISTER
+ DB_RENUMBER DB_SEQ_WRAP DB_SNAPSHOT DB_STAT_ALL DB_ST_DUPOK DB_ST_RELEN
+ DB_TRUNCATE DB_TXNMAGIC DB_TXN_BULK DB_TXN_LOCK DB_TXN_REDO DB_TXN_SYNC
+ DB_TXN_UNDO DB_TXN_WAIT DB_WRNOSYNC DB_YIELDCPU LOGREC_DATA LOGREC_DBOP
+ LOGREC_Done LOGREC_TIME */
+ /* Offset 8 gives the best switch position. */
+ switch (name[8]) {
+ case 'A':
+ if (memEQ(name, "DB_ARCH_ABS", 11)) {
+ /* ^ */
+#ifdef DB_ARCH_ABS
+ *iv_return = DB_ARCH_ABS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_ALL", 11)) {
+ /* ^ */
+#ifdef DB_STAT_ALL
+ *iv_return = DB_STAT_ALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TRUNCATE", 11)) {
+ /* ^ */
+#ifdef DB_TRUNCATE
+ *iv_return = DB_TRUNCATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_WAIT", 11)) {
+ /* ^ */
+#ifdef DB_TXN_WAIT
+ *iv_return = DB_TXN_WAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_DATA", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_DATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "DB_RENUMBER", 11)) {
+ /* ^ */
+#ifdef DB_RENUMBER
+ *iv_return = DB_RENUMBER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_DBOP", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_DBOP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_INIT_CDB", 11)) {
+ /* ^ */
+#ifdef DB_INIT_CDB
+ *iv_return = DB_INIT_CDB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OK_RECNO", 11)) {
+ /* ^ */
+#ifdef DB_OK_RECNO
+ *iv_return = DB_OK_RECNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_YIELDCPU", 11)) {
+ /* ^ */
+#ifdef DB_YIELDCPU
+ *iv_return = DB_YIELDCPU;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_NEXT_DUP", 11)) {
+ /* ^ */
+#ifdef DB_NEXT_DUP
+ *iv_return = DB_NEXT_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PREV_DUP", 11)) {
+ /* ^ */
+#ifdef DB_PREV_DUP
+ *iv_return = DB_PREV_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_DEGREE_2", 11)) {
+ /* ^ */
+#ifdef DB_DEGREE_2
+ *iv_return = DB_DEGREE_2;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_PERM", 11)) {
+ /* ^ */
+#ifdef DB_LOG_PERM
+ *iv_return = DB_LOG_PERM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_ZERO", 11)) {
+ /* ^ */
+#ifdef DB_LOG_ZERO
+ *iv_return = DB_LOG_ZERO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OK_QUEUE", 11)) {
+ /* ^ */
+#ifdef DB_OK_QUEUE
+ *iv_return = DB_OK_QUEUE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_REDO", 11)) {
+ /* ^ */
+#ifdef DB_TXN_REDO
+ *iv_return = DB_TXN_REDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_LOCK_GET", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_LOCK_GET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOGMAGIC", 11)) {
+ /* ^ */
+#ifdef DB_LOGMAGIC
+ *iv_return = DB_LOGMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_QAMMAGIC", 11)) {
+ /* ^ */
+#ifdef DB_QAMMAGIC
+ *iv_return = DB_QAMMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXNMAGIC", 11)) {
+ /* ^ */
+#ifdef DB_TXNMAGIC
+ *iv_return = DB_TXNMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_SNAPSHOT", 11)) {
+ /* ^ */
+#ifdef DB_SNAPSHOT
+ *iv_return = DB_SNAPSHOT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_GID_SIZE", 11)) {
+ /* ^ */
+#ifdef DB_GID_SIZE
+ *iv_return = DB_GID_SIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_KEYEXIST", 11)) {
+ /* ^ */
+#ifdef DB_KEYEXIST
+ *iv_return = DB_KEYEXIST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_DISK", 11)) {
+ /* ^ */
+#ifdef DB_LOG_DISK
+ *iv_return = DB_LOG_DISK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_POSITION", 11)) {
+ /* ^ */
+#ifdef DB_POSITION
+ *iv_return = DB_POSITION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_TIME", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_TIME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_ARCH_LOG", 11)) {
+ /* ^ */
+#ifdef DB_ARCH_LOG
+ *iv_return = DB_ARCH_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FIXEDLEN", 11)) {
+ /* ^ */
+#ifdef DB_FIXEDLEN
+ *iv_return = DB_FIXEDLEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_INIT_LOG", 11)) {
+ /* ^ */
+#ifdef DB_INIT_LOG
+ *iv_return = DB_INIT_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_RELEN", 11)) {
+ /* ^ */
+#ifdef DB_ST_RELEN
+ *iv_return = DB_ST_RELEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_APP_INIT", 11)) {
+ /* ^ */
+#ifdef DB_APP_INIT
+ *iv_return = DB_APP_INIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_UNDO", 11)) {
+ /* ^ */
+#ifdef DB_TXN_UNDO
+ *iv_return = DB_TXN_UNDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_GET_BOTH", 11)) {
+ /* ^ */
+#ifdef DB_GET_BOTH
+ *iv_return = DB_GET_BOTH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCKDOWN", 11)) {
+ /* ^ */
+#ifdef DB_LOCKDOWN
+ *iv_return = DB_LOCKDOWN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MEM_LOCK", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOCK", 11)) {
+ /* ^ */
+#ifdef DB_TXN_LOCK
+ *iv_return = DB_TXN_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_FILEOPEN", 11)) {
+ /* ^ */
+#ifdef DB_FILEOPEN
+ *iv_return = DB_FILEOPEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_KEYEMPTY", 11)) {
+ /* ^ */
+#ifdef DB_KEYEMPTY
+ *iv_return = DB_KEYEMPTY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_PUT", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_LOCK_PUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MULTIPLE", 11)) {
+ /* ^ */
+#ifdef DB_MULTIPLE
+ *iv_return = DB_MULTIPLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_DUPOK", 11)) {
+ /* ^ */
+#ifdef DB_ST_DUPOK
+ *iv_return = DB_ST_DUPOK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_INIT_REP", 11)) {
+ /* ^ */
+#ifdef DB_INIT_REP
+ *iv_return = DB_INIT_REP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_KEYFIRST", 11)) {
+ /* ^ */
+#ifdef DB_KEYFIRST
+ *iv_return = DB_KEYFIRST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OK_BTREE", 11)) {
+ /* ^ */
+#ifdef DB_OK_BTREE
+ *iv_return = DB_OK_BTREE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQ_WRAP", 11)) {
+ /* ^ */
+#ifdef DB_SEQ_WRAP
+ *iv_return = DB_SEQ_WRAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_INIT_TXN", 11)) {
+ /* ^ */
+#ifdef DB_INIT_TXN
+ *iv_return = DB_INIT_TXN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGISTER", 11)) {
+ /* ^ */
+#ifdef DB_REGISTER
+ *iv_return = DB_REGISTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_NOTFOUND", 11)) {
+ /* ^ */
+#ifdef DB_NOTFOUND
+ *iv_return = DB_NOTFOUND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_BULK", 11)) {
+ /* ^ */
+#ifdef DB_TXN_BULK
+ *iv_return = DB_TXN_BULK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'V':
+ if (memEQ(name, "DB_NOSERVER", 11)) {
+ /* ^ */
+#ifdef DB_NOSERVER
+ *iv_return = DB_NOSERVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB2_AM_EXCL", 11)) {
+ /* ^ */
+#ifdef DB2_AM_EXCL
+ *iv_return = DB2_AM_EXCL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_TXN_SYNC", 11)) {
+ /* ^ */
+#ifdef DB_TXN_SYNC
+ *iv_return = DB_TXN_SYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_WRNOSYNC", 11)) {
+ /* ^ */
+#ifdef DB_WRNOSYNC
+ *iv_return = DB_WRNOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_DSYNC_DB", 11)) {
+ /* ^ */
+#ifdef DB_DSYNC_DB
+ *iv_return = DB_DSYNC_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'o':
+ if (memEQ(name, "LOGREC_Done", 11)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_Done;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_12 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_ARCH_DATA DB_CDB_ALLDB DB_CL_WRITER DB_DELIMITER DB_DIRECT_DB
+ DB_DSYNC_LOG DB_DUPCURSOR DB_ENV_FATAL DB_FAST_STAT DB_FORCESYNC
+ DB_GET_BOTHC DB_GET_RECNO DB_HASHMAGIC DB_HEAPMAGIC DB_HEAP_FULL
+ DB_INIT_LOCK DB_JOIN_ITEM DB_LOCKMAGIC DB_LOCK_DUMP DB_LOCK_RW_N
+ DB_LOGCHKSUM DB_LOGOLDVER DB_LOG_DSYNC DB_MAX_PAGES DB_MEM_LOGID
+ DB_MPOOL_NEW DB_MPOOL_TRY DB_NEEDSPLIT DB_NODUPDATA DB_NOLOCKING
+ DB_NORECURSE DB_OVERWRITE DB_PAGEYIELD DB_PAGE_LOCK DB_PERMANENT
+ DB_POSITIONI DB_PRINTABLE DB_QAMOLDVER DB_RPCCLIENT DB_SET_RANGE
+ DB_SET_RECNO DB_ST_DUPSET DB_ST_RECNUM DB_SWAPBYTES DB_TEMPORARY
+ DB_TXN_ABORT DB_TXN_APPLY DB_TXN_PRINT DB_WRITELOCK DB_WRITEOPEN
+ DB_XA_CREATE LOGREC_LOCKS LOGREC_PGDBT */
+ /* Offset 3 gives the best switch position. */
+ switch (name[3]) {
+ case 'A':
+ if (memEQ(name, "DB_ARCH_DATA", 12)) {
+ /* ^ */
+#ifdef DB_ARCH_DATA
+ *iv_return = DB_ARCH_DATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_CDB_ALLDB", 12)) {
+ /* ^ */
+#ifdef DB_CDB_ALLDB
+ *iv_return = DB_CDB_ALLDB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_CL_WRITER", 12)) {
+ /* ^ */
+#ifdef DB_CL_WRITER
+ *iv_return = DB_CL_WRITER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_DELIMITER", 12)) {
+ /* ^ */
+#ifdef DB_DELIMITER
+ *iv_return = DB_DELIMITER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_DIRECT_DB", 12)) {
+ /* ^ */
+#ifdef DB_DIRECT_DB
+ *iv_return = DB_DIRECT_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_DSYNC_LOG", 12)) {
+ /* ^ */
+#ifdef DB_DSYNC_LOG
+ *iv_return = DB_DSYNC_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_DUPCURSOR", 12)) {
+ /* ^ */
+#ifdef DB_DUPCURSOR
+ *iv_return = DB_DUPCURSOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_ENV_FATAL", 12)) {
+ /* ^ */
+#ifdef DB_ENV_FATAL
+ *iv_return = DB_ENV_FATAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_FAST_STAT", 12)) {
+ /* ^ */
+#ifdef DB_FAST_STAT
+ *iv_return = DB_FAST_STAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FORCESYNC", 12)) {
+ /* ^ */
+#ifdef DB_FORCESYNC
+ *iv_return = DB_FORCESYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_GET_BOTHC", 12)) {
+ /* ^ */
+#ifdef DB_GET_BOTHC
+ *iv_return = DB_GET_BOTHC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_GET_RECNO", 12)) {
+ /* ^ */
+#ifdef DB_GET_RECNO
+ *iv_return = DB_GET_RECNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_HASHMAGIC", 12)) {
+ /* ^ */
+#ifdef DB_HASHMAGIC
+ *iv_return = DB_HASHMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HEAPMAGIC", 12)) {
+ /* ^ */
+#ifdef DB_HEAPMAGIC
+ *iv_return = DB_HEAPMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HEAP_FULL", 12)) {
+ /* ^ */
+#ifdef DB_HEAP_FULL
+ *iv_return = DB_HEAP_FULL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_INIT_LOCK", 12)) {
+ /* ^ */
+#ifdef DB_INIT_LOCK
+ *iv_return = DB_INIT_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'J':
+ if (memEQ(name, "DB_JOIN_ITEM", 12)) {
+ /* ^ */
+#ifdef DB_JOIN_ITEM
+ *iv_return = DB_JOIN_ITEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_LOCKMAGIC", 12)) {
+ /* ^ */
+#ifdef DB_LOCKMAGIC
+ *iv_return = DB_LOCKMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_DUMP", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_LOCK_DUMP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_RW_N", 12)) {
+ /* ^ */
+#ifdef DB_LOCK_RW_N
+ *iv_return = DB_LOCK_RW_N;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOGCHKSUM", 12)) {
+ /* ^ */
+#ifdef DB_LOGCHKSUM
+ *iv_return = DB_LOGCHKSUM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOGOLDVER", 12)) {
+ /* ^ */
+#ifdef DB_LOGOLDVER
+ *iv_return = DB_LOGOLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_DSYNC", 12)) {
+ /* ^ */
+#ifdef DB_LOG_DSYNC
+ *iv_return = DB_LOG_DSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_MAX_PAGES", 12)) {
+ /* ^ */
+#ifdef DB_MAX_PAGES
+ *iv_return = DB_MAX_PAGES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MEM_LOGID", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_LOGID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_NEW", 12)) {
+ /* ^ */
+#ifdef DB_MPOOL_NEW
+ *iv_return = DB_MPOOL_NEW;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_TRY", 12)) {
+ /* ^ */
+#ifdef DB_MPOOL_TRY
+ *iv_return = DB_MPOOL_TRY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_NEEDSPLIT", 12)) {
+ /* ^ */
+#ifdef DB_NEEDSPLIT
+ *iv_return = DB_NEEDSPLIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NODUPDATA", 12)) {
+ /* ^ */
+#ifdef DB_NODUPDATA
+ *iv_return = DB_NODUPDATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOLOCKING", 12)) {
+ /* ^ */
+#ifdef DB_NOLOCKING
+ *iv_return = DB_NOLOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NORECURSE", 12)) {
+ /* ^ */
+#ifdef DB_NORECURSE
+ *iv_return = DB_NORECURSE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_OVERWRITE", 12)) {
+ /* ^ */
+#ifdef DB_OVERWRITE
+ *iv_return = DB_OVERWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_PAGEYIELD", 12)) {
+ /* ^ */
+#ifdef DB_PAGEYIELD
+ *iv_return = DB_PAGEYIELD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PAGE_LOCK", 12)) {
+ /* ^ */
+#ifdef DB_PAGE_LOCK
+ *iv_return = DB_PAGE_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PERMANENT", 12)) {
+ /* ^ */
+#ifdef DB_PERMANENT
+ *iv_return = DB_PERMANENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_POSITIONI", 12)) {
+ /* ^ */
+#ifdef DB_POSITIONI
+ *iv_return = DB_POSITIONI;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PRINTABLE", 12)) {
+ /* ^ */
+#ifdef DB_PRINTABLE
+ *iv_return = DB_PRINTABLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Q':
+ if (memEQ(name, "DB_QAMOLDVER", 12)) {
+ /* ^ */
+#ifdef DB_QAMOLDVER
+ *iv_return = DB_QAMOLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_RPCCLIENT", 12)) {
+ /* ^ */
+#ifdef DB_RPCCLIENT
+ *iv_return = DB_RPCCLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_LOCKS", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_LOCKS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_PGDBT", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_PGDBT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_SET_RANGE", 12)) {
+ /* ^ */
+#ifdef DB_SET_RANGE
+ *iv_return = DB_SET_RANGE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SET_RECNO", 12)) {
+ /* ^ */
+#ifdef DB_SET_RECNO
+ *iv_return = DB_SET_RECNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_DUPSET", 12)) {
+ /* ^ */
+#ifdef DB_ST_DUPSET
+ *iv_return = DB_ST_DUPSET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_RECNUM", 12)) {
+ /* ^ */
+#ifdef DB_ST_RECNUM
+ *iv_return = DB_ST_RECNUM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SWAPBYTES", 12)) {
+ /* ^ */
+#ifdef DB_SWAPBYTES
+ *iv_return = DB_SWAPBYTES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_TEMPORARY", 12)) {
+ /* ^ */
+#ifdef DB_TEMPORARY
+ *iv_return = DB_TEMPORARY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_ABORT", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 3) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_ABORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_APPLY", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_APPLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_PRINT", 12)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_TXN_PRINT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_WRITELOCK", 12)) {
+ /* ^ */
+#ifdef DB_WRITELOCK
+ *iv_return = DB_WRITELOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_WRITEOPEN", 12)) {
+ /* ^ */
+#ifdef DB_WRITEOPEN
+ *iv_return = DB_WRITEOPEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB_XA_CREATE", 12)) {
+ /* ^ */
+#ifdef DB_XA_CREATE
+ *iv_return = DB_XA_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_13 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB2_AM_NOWAIT DB_AGGRESSIVE DB_BTREEMAGIC DB_CHECKPOINT DB_DIRECT_LOG
+ DB_DIRTY_READ DB_DONOTINDEX DB_EID_MASTER DB_ENV_CREATE DB_ENV_NOMMAP
+ DB_ENV_THREAD DB_FREE_SPACE DB_HASHOLDVER DB_HEAPOLDVER DB_INCOMPLETE
+ DB_INIT_MPOOL DB_INIT_MUTEX DB_LOCAL_SITE DB_LOCK_ABORT DB_LOCK_CHECK
+ DB_LOCK_NORUN DB_LOCK_RIW_N DB_LOCK_TRADE DB_LOGVERSION DB_LOG_CHKPNT
+ DB_LOG_COMMIT DB_LOG_DIRECT DB_LOG_LOCKED DB_LOG_NOCOPY DB_LOG_RESEND
+ DB_MEM_LOCKER DB_MEM_THREAD DB_MPOOL_EDIT DB_MPOOL_FREE DB_MPOOL_LAST
+ DB_MUTEXDEBUG DB_MUTEXLOCKS DB_NEXT_NODUP DB_NOORDERCHK DB_PREV_NODUP
+ DB_PR_HEADERS DB_QAMVERSION DB_RDWRMASTER DB_REGISTERED DB_REP_CLIENT
+ DB_REP_CREATE DB_REP_IGNORE DB_REP_ISPERM DB_REP_MASTER DB_SEQUENTIAL
+ DB_SPARE_FLAG DB_STAT_ALLOC DB_STAT_CLEAR DB_ST_DUPSORT DB_SYSTEM_MEM
+ DB_TXNVERSION DB_TXN_FAMILY DB_TXN_NOSYNC DB_TXN_NOWAIT DB_VERIFY_BAD
+ DB_debug_FLAG DB_user_BEGIN LOGREC_PGDDBT LOGREC_PGLIST */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'A':
+ if (memEQ(name, "DB_HEAPOLDVER", 13)) {
+ /* ^ */
+#ifdef DB_HEAPOLDVER
+ *iv_return = DB_HEAPOLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SPARE_FLAG", 13)) {
+ /* ^ */
+#ifdef DB_SPARE_FLAG
+ *iv_return = DB_SPARE_FLAG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_ALLOC", 13)) {
+ /* ^ */
+#ifdef DB_STAT_ALLOC
+ *iv_return = DB_STAT_ALLOC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_CLEAR", 13)) {
+ /* ^ */
+#ifdef DB_STAT_CLEAR
+ *iv_return = DB_STAT_CLEAR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_INCOMPLETE", 13)) {
+ /* ^ */
+#ifdef DB_INCOMPLETE
+ *iv_return = DB_INCOMPLETE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCAL_SITE", 13)) {
+ /* ^ */
+#ifdef DB_LOCAL_SITE
+ *iv_return = DB_LOCAL_SITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_ABORT", 13)) {
+ /* ^ */
+#ifdef DB_LOCK_ABORT
+ *iv_return = DB_LOCK_ABORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_CHECK", 13)) {
+ /* ^ */
+#ifdef DB_LOCK_CHECK
+ *iv_return = DB_LOCK_CHECK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_NORUN", 13)) {
+ /* ^ */
+#ifdef DB_LOCK_NORUN
+ *iv_return = DB_LOCK_NORUN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_RIW_N", 13)) {
+ /* ^ */
+#ifdef DB_LOCK_RIW_N
+ *iv_return = DB_LOCK_RIW_N;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_TRADE", 13)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_LOCK_TRADE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_PGDDBT", 13)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_PGDDBT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_PGLIST", 13)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_PGLIST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_EID_MASTER", 13)) {
+ /* ^ */
+#ifdef DB_EID_MASTER
+ *iv_return = DB_EID_MASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_CHECKPOINT", 13)) {
+ /* ^ */
+#ifdef DB_CHECKPOINT
+ *iv_return = DB_CHECKPOINT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FREE_SPACE", 13)) {
+ /* ^ */
+#ifdef DB_FREE_SPACE
+ *iv_return = DB_FREE_SPACE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PREV_NODUP", 13)) {
+ /* ^ */
+#ifdef DB_PREV_NODUP
+ *iv_return = DB_PREV_NODUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_AGGRESSIVE", 13)) {
+ /* ^ */
+#ifdef DB_AGGRESSIVE
+ *iv_return = DB_AGGRESSIVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOGVERSION", 13)) {
+ /* ^ */
+#ifdef DB_LOGVERSION
+ *iv_return = DB_LOGVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_CHKPNT", 13)) {
+ /* ^ */
+#ifdef DB_LOG_CHKPNT
+ *iv_return = DB_LOG_CHKPNT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_COMMIT", 13)) {
+ /* ^ */
+#ifdef DB_LOG_COMMIT
+ *iv_return = DB_LOG_COMMIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_DIRECT", 13)) {
+ /* ^ */
+#ifdef DB_LOG_DIRECT
+ *iv_return = DB_LOG_DIRECT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_LOCKED", 13)) {
+ /* ^ */
+#ifdef DB_LOG_LOCKED
+ *iv_return = DB_LOG_LOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_NOCOPY", 13)) {
+ /* ^ */
+#ifdef DB_LOG_NOCOPY
+ *iv_return = DB_LOG_NOCOPY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_RESEND", 13)) {
+ /* ^ */
+#ifdef DB_LOG_RESEND
+ *iv_return = DB_LOG_RESEND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGISTERED", 13)) {
+ /* ^ */
+#ifdef DB_REGISTERED
+ *iv_return = DB_REGISTERED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_INIT_MPOOL", 13)) {
+ /* ^ */
+#ifdef DB_INIT_MPOOL
+ *iv_return = DB_INIT_MPOOL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_INIT_MUTEX", 13)) {
+ /* ^ */
+#ifdef DB_INIT_MUTEX
+ *iv_return = DB_INIT_MUTEX;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB2_AM_NOWAIT", 13)) {
+ /* ^ */
+#ifdef DB2_AM_NOWAIT
+ *iv_return = DB2_AM_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MEM_LOCKER", 13)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_LOCKER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MEM_THREAD", 13)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_THREAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_QAMVERSION", 13)) {
+ /* ^ */
+#ifdef DB_QAMVERSION
+ *iv_return = DB_QAMVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_DONOTINDEX", 13)) {
+ /* ^ */
+#ifdef DB_DONOTINDEX
+ *iv_return = DB_DONOTINDEX;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXNVERSION", 13)) {
+ /* ^ */
+#ifdef DB_TXNVERSION
+ *iv_return = DB_TXNVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_FAMILY", 13)) {
+ /* ^ */
+#ifdef DB_TXN_FAMILY
+ *iv_return = DB_TXN_FAMILY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_NOSYNC", 13)) {
+ /* ^ */
+#ifdef DB_TXN_NOSYNC
+ *iv_return = DB_TXN_NOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_NOWAIT", 13)) {
+ /* ^ */
+#ifdef DB_TXN_NOWAIT
+ *iv_return = DB_TXN_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_MPOOL_EDIT", 13)) {
+ /* ^ */
+#ifdef DB_MPOOL_EDIT
+ *iv_return = DB_MPOOL_EDIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_FREE", 13)) {
+ /* ^ */
+#ifdef DB_MPOOL_FREE
+ *iv_return = DB_MPOOL_FREE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_LAST", 13)) {
+ /* ^ */
+#ifdef DB_MPOOL_LAST
+ *iv_return = DB_MPOOL_LAST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOORDERCHK", 13)) {
+ /* ^ */
+#ifdef DB_NOORDERCHK
+ *iv_return = DB_NOORDERCHK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_REP_CLIENT", 13)) {
+ /* ^ */
+#ifdef DB_REP_CLIENT
+ *iv_return = DB_REP_CLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_CREATE", 13)) {
+ /* ^ */
+#ifdef DB_REP_CREATE
+ *iv_return = DB_REP_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_IGNORE", 13)) {
+ /* ^ */
+#ifdef DB_REP_IGNORE
+ *iv_return = DB_REP_IGNORE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_ISPERM", 13)) {
+ /* ^ */
+#ifdef DB_REP_ISPERM
+ *iv_return = DB_REP_ISPERM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_MASTER", 13)) {
+ /* ^ */
+#ifdef DB_REP_MASTER
+ *iv_return = DB_REP_MASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Q':
+ if (memEQ(name, "DB_SEQUENTIAL", 13)) {
+ /* ^ */
+#ifdef DB_SEQUENTIAL
+ *iv_return = DB_SEQUENTIAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_BTREEMAGIC", 13)) {
+ /* ^ */
+#ifdef DB_BTREEMAGIC
+ *iv_return = DB_BTREEMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_DIRECT_LOG", 13)) {
+ /* ^ */
+#ifdef DB_DIRECT_LOG
+ *iv_return = DB_DIRECT_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_DIRTY_READ", 13)) {
+ /* ^ */
+#ifdef DB_DIRTY_READ
+ *iv_return = DB_DIRTY_READ;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERIFY_BAD", 13)) {
+ /* ^ */
+#ifdef DB_VERIFY_BAD
+ *iv_return = DB_VERIFY_BAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_HASHOLDVER", 13)) {
+ /* ^ */
+#ifdef DB_HASHOLDVER
+ *iv_return = DB_HASHOLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SYSTEM_MEM", 13)) {
+ /* ^ */
+#ifdef DB_SYSTEM_MEM
+ *iv_return = DB_SYSTEM_MEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_MUTEXDEBUG", 13)) {
+ /* ^ */
+#ifdef DB_MUTEXDEBUG
+ *iv_return = DB_MUTEXDEBUG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MUTEXLOCKS", 13)) {
+ /* ^ */
+#ifdef DB_MUTEXLOCKS
+ *iv_return = DB_MUTEXLOCKS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'V':
+ if (memEQ(name, "DB_ENV_CREATE", 13)) {
+ /* ^ */
+#ifdef DB_ENV_CREATE
+ *iv_return = DB_ENV_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_NOMMAP", 13)) {
+ /* ^ */
+#ifdef DB_ENV_NOMMAP
+ *iv_return = DB_ENV_NOMMAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_THREAD", 13)) {
+ /* ^ */
+#ifdef DB_ENV_THREAD
+ *iv_return = DB_ENV_THREAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_RDWRMASTER", 13)) {
+ /* ^ */
+#ifdef DB_RDWRMASTER
+ *iv_return = DB_RDWRMASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB_NEXT_NODUP", 13)) {
+ /* ^ */
+#ifdef DB_NEXT_NODUP
+ *iv_return = DB_NEXT_NODUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_PR_HEADERS", 13)) {
+ /* ^ */
+#ifdef DB_PR_HEADERS
+ *iv_return = DB_PR_HEADERS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_DUPSORT", 13)) {
+ /* ^ */
+#ifdef DB_ST_DUPSORT
+ *iv_return = DB_ST_DUPSORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'b':
+ if (memEQ(name, "DB_debug_FLAG", 13)) {
+ /* ^ */
+#ifdef DB_debug_FLAG
+ *iv_return = DB_debug_FLAG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'e':
+ if (memEQ(name, "DB_user_BEGIN", 13)) {
+ /* ^ */
+#ifdef DB_user_BEGIN
+ *iv_return = DB_user_BEGIN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_14 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB2_AM_INTEXCL DB_ARCH_REMOVE DB_AUTO_COMMIT DB_BACKUP_SIZE DB_BTREEOLDVER
+ DB_CHKSUM_SHA1 DB_CURSOR_BULK DB_EID_INVALID DB_ENCRYPT_AES DB_ENV_APPINIT
+ DB_ENV_DBLOCAL DB_ENV_FAILCHK DB_ENV_LOCKING DB_ENV_LOGGING DB_ENV_NOFLUSH
+ DB_ENV_NOPANIC DB_ENV_PRIVATE DB_EVENT_PANIC DB_FILE_ID_LEN DB_HANDLE_LOCK
+ DB_HASHVERSION DB_HEAPVERSION DB_HEAP_RID_SZ DB_INTERNAL_DB DB_JOIN_NOSORT
+ DB_LOCKVERSION DB_LOCK_EXPIRE DB_LOCK_NOWAIT DB_LOCK_OLDEST DB_LOCK_RANDOM
+ DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_SWITCH DB_LOG_NO_DATA DB_MAX_RECORDS
+ DB_MPOOL_CLEAN DB_MPOOL_DIRTY DB_NOOVERWRITE DB_NOSERVER_ID DB_ODDFILESIZE
+ DB_OLD_VERSION DB_OPEN_CALLED DB_RECORDCOUNT DB_RECORD_LOCK DB_REGION_ANON
+ DB_REGION_INIT DB_REGION_NAME DB_RENAMEMAGIC DB_REPMGR_PEER DB_REP_BULKOVF
+ DB_REP_EGENCHG DB_REP_LOCKOUT DB_REP_NEWSITE DB_REP_NOTPERM DB_REP_UNAVAIL
+ DB_REVSPLITOFF DB_RUNRECOVERY DB_SEQ_WRAPPED DB_SET_TXN_NOW DB_SHALLOW_DUP
+ DB_ST_IS_RECNO DB_ST_TOPLEVEL DB_USE_ENVIRON DB_VERB_BACKUP DB_WRITECURSOR
+ DB_XIDDATASIZE LOGREC_POINTER */
+ /* Offset 13 gives the best switch position. */
+ switch (name[13]) {
+ case '1':
+ if (memEQ(name, "DB_CHKSUM_SHA", 13)) {
+ /* 1 */
+#ifdef DB_CHKSUM_SHA1
+ *iv_return = DB_CHKSUM_SHA1;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'A':
+ if (memEQ(name, "DB_LOG_NO_DAT", 13)) {
+ /* A */
+#ifdef DB_LOG_NO_DATA
+ *iv_return = DB_LOG_NO_DATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "DB_INTERNAL_D", 13)) {
+ /* B */
+#ifdef DB_INTERNAL_DB
+ *iv_return = DB_INTERNAL_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_ENV_NOPANI", 13)) {
+ /* C */
+#ifdef DB_ENV_NOPANIC
+ *iv_return = DB_ENV_NOPANIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_EVENT_PANI", 13)) {
+ /* C */
+#ifdef DB_EVENT_PANIC
+ *iv_return = DB_EVENT_PANIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RENAMEMAGI", 13)) {
+ /* C */
+#ifdef DB_RENAMEMAGIC
+ *iv_return = DB_RENAMEMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_EID_INVALI", 13)) {
+ /* D */
+#ifdef DB_EID_INVALID
+ *iv_return = DB_EID_INVALID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_RECOR", 13)) {
+ /* D */
+#ifdef DB_LOCK_RECORD
+ *iv_return = DB_LOCK_RECORD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOSERVER_I", 13)) {
+ /* D */
+#ifdef DB_NOSERVER_ID
+ *iv_return = DB_NOSERVER_ID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OPEN_CALLE", 13)) {
+ /* D */
+#ifdef DB_OPEN_CALLED
+ *iv_return = DB_OPEN_CALLED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQ_WRAPPE", 13)) {
+ /* D */
+#ifdef DB_SEQ_WRAPPED
+ *iv_return = DB_SEQ_WRAPPED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_ARCH_REMOV", 13)) {
+ /* E */
+#ifdef DB_ARCH_REMOVE
+ *iv_return = DB_ARCH_REMOVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_BACKUP_SIZ", 13)) {
+ /* E */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \
+ DB_VERSION_PATCH >= 5)
+ *iv_return = DB_BACKUP_SIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_PRIVAT", 13)) {
+ /* E */
+#ifdef DB_ENV_PRIVATE
+ *iv_return = DB_ENV_PRIVATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_EXPIR", 13)) {
+ /* E */
+#ifdef DB_LOCK_EXPIRE
+ *iv_return = DB_LOCK_EXPIRE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_REMOV", 13)) {
+ /* E */
+#ifdef DB_LOCK_REMOVE
+ *iv_return = DB_LOCK_REMOVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOOVERWRIT", 13)) {
+ /* E */
+#ifdef DB_NOOVERWRITE
+ *iv_return = DB_NOOVERWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ODDFILESIZ", 13)) {
+ /* E */
+#ifdef DB_ODDFILESIZE
+ *iv_return = DB_ODDFILESIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGION_NAM", 13)) {
+ /* E */
+#ifdef DB_REGION_NAME
+ *iv_return = DB_REGION_NAME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_NEWSIT", 13)) {
+ /* E */
+#ifdef DB_REP_NEWSITE
+ *iv_return = DB_REP_NEWSITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_XIDDATASIZ", 13)) {
+ /* E */
+#ifdef DB_XIDDATASIZE
+ *iv_return = DB_XIDDATASIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_REP_BULKOV", 13)) {
+ /* F */
+#ifdef DB_REP_BULKOVF
+ *iv_return = DB_REP_BULKOVF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REVSPLITOF", 13)) {
+ /* F */
+#ifdef DB_REVSPLITOFF
+ *iv_return = DB_REVSPLITOFF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_ENV_LOCKIN", 13)) {
+ /* G */
+#ifdef DB_ENV_LOCKING
+ *iv_return = DB_ENV_LOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_LOGGIN", 13)) {
+ /* G */
+#ifdef DB_ENV_LOGGING
+ *iv_return = DB_ENV_LOGGING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_EGENCH", 13)) {
+ /* G */
+#ifdef DB_REP_EGENCHG
+ *iv_return = DB_REP_EGENCHG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_ENV_NOFLUS", 13)) {
+ /* H */
+#ifdef DB_ENV_NOFLUSH
+ *iv_return = DB_ENV_NOFLUSH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_SWITC", 13)) {
+ /* H */
+#ifdef DB_LOCK_SWITCH
+ *iv_return = DB_LOCK_SWITCH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_CURSOR_BUL", 13)) {
+ /* K */
+#ifdef DB_CURSOR_BULK
+ *iv_return = DB_CURSOR_BULK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_FAILCH", 13)) {
+ /* K */
+#ifdef DB_ENV_FAILCHK
+ *iv_return = DB_ENV_FAILCHK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HANDLE_LOC", 13)) {
+ /* K */
+#ifdef DB_HANDLE_LOCK
+ *iv_return = DB_HANDLE_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RECORD_LOC", 13)) {
+ /* K */
+#ifdef DB_RECORD_LOCK
+ *iv_return = DB_RECORD_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB2_AM_INTEXC", 13)) {
+ /* L */
+#ifdef DB2_AM_INTEXCL
+ *iv_return = DB2_AM_INTEXCL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_DBLOCA", 13)) {
+ /* L */
+#ifdef DB_ENV_DBLOCAL
+ *iv_return = DB_ENV_DBLOCAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_UNAVAI", 13)) {
+ /* L */
+#ifdef DB_REP_UNAVAIL
+ *iv_return = DB_REP_UNAVAIL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_TOPLEVE", 13)) {
+ /* L */
+#ifdef DB_ST_TOPLEVEL
+ *iv_return = DB_ST_TOPLEVEL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_LOCK_RANDO", 13)) {
+ /* M */
+#ifdef DB_LOCK_RANDOM
+ *iv_return = DB_LOCK_RANDOM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_NOTPER", 13)) {
+ /* M */
+#ifdef DB_REP_NOTPERM
+ *iv_return = DB_REP_NOTPERM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_FILE_ID_LE", 13)) {
+ /* N */
+#ifdef DB_FILE_ID_LEN
+ *iv_return = DB_FILE_ID_LEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HASHVERSIO", 13)) {
+ /* N */
+#ifdef DB_HASHVERSION
+ *iv_return = DB_HASHVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_HEAPVERSIO", 13)) {
+ /* N */
+#ifdef DB_HEAPVERSION
+ *iv_return = DB_HEAPVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCKVERSIO", 13)) {
+ /* N */
+#ifdef DB_LOCKVERSION
+ *iv_return = DB_LOCKVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_CLEA", 13)) {
+ /* N */
+#ifdef DB_MPOOL_CLEAN
+ *iv_return = DB_MPOOL_CLEAN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OLD_VERSIO", 13)) {
+ /* N */
+#ifdef DB_OLD_VERSION
+ *iv_return = DB_OLD_VERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGION_ANO", 13)) {
+ /* N */
+#ifdef DB_REGION_ANON
+ *iv_return = DB_REGION_ANON;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_USE_ENVIRO", 13)) {
+ /* N */
+#ifdef DB_USE_ENVIRON
+ *iv_return = DB_USE_ENVIRON;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_ST_IS_RECN", 13)) {
+ /* O */
+#ifdef DB_ST_IS_RECNO
+ *iv_return = DB_ST_IS_RECNO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_SHALLOW_DU", 13)) {
+ /* P */
+#ifdef DB_SHALLOW_DUP
+ *iv_return = DB_SHALLOW_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_BACKU", 13)) {
+ /* P */
+#ifdef DB_VERB_BACKUP
+ *iv_return = DB_VERB_BACKUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_BTREEOLDVE", 13)) {
+ /* R */
+#ifdef DB_BTREEOLDVER
+ *iv_return = DB_BTREEOLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_PEE", 13)) {
+ /* R */
+#ifdef DB_REPMGR_PEER
+ *iv_return = DB_REPMGR_PEER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_WRITECURSO", 13)) {
+ /* R */
+#ifdef DB_WRITECURSOR
+ *iv_return = DB_WRITECURSOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOGREC_POINTE", 13)) {
+ /* R */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = LOGREC_POINTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_ENCRYPT_AE", 13)) {
+ /* S */
+#ifdef DB_ENCRYPT_AES
+ *iv_return = DB_ENCRYPT_AES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MAX_RECORD", 13)) {
+ /* S */
+#ifdef DB_MAX_RECORDS
+ *iv_return = DB_MAX_RECORDS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_AUTO_COMMI", 13)) {
+ /* T */
+#ifdef DB_AUTO_COMMIT
+ *iv_return = DB_AUTO_COMMIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_APPINI", 13)) {
+ /* T */
+#ifdef DB_ENV_APPINIT
+ *iv_return = DB_ENV_APPINIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_JOIN_NOSOR", 13)) {
+ /* T */
+#ifdef DB_JOIN_NOSORT
+ *iv_return = DB_JOIN_NOSORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_NOWAI", 13)) {
+ /* T */
+#ifdef DB_LOCK_NOWAIT
+ *iv_return = DB_LOCK_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_OLDES", 13)) {
+ /* T */
+#ifdef DB_LOCK_OLDEST
+ *iv_return = DB_LOCK_OLDEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RECORDCOUN", 13)) {
+ /* T */
+#ifdef DB_RECORDCOUNT
+ *iv_return = DB_RECORDCOUNT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGION_INI", 13)) {
+ /* T */
+#ifdef DB_REGION_INIT
+ *iv_return = DB_REGION_INIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_LOCKOU", 13)) {
+ /* T */
+#ifdef DB_REP_LOCKOUT
+ *iv_return = DB_REP_LOCKOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_SET_TXN_NO", 13)) {
+ /* W */
+#ifdef DB_SET_TXN_NOW
+ *iv_return = DB_SET_TXN_NOW;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_MPOOL_DIRT", 13)) {
+ /* Y */
+#ifdef DB_MPOOL_DIRTY
+ *iv_return = DB_MPOOL_DIRTY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RUNRECOVER", 13)) {
+ /* Y */
+#ifdef DB_RUNRECOVERY
+ *iv_return = DB_RUNRECOVERY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Z':
+ if (memEQ(name, "DB_HEAP_RID_S", 13)) {
+ /* Z */
+#ifdef DB_HEAP_RID_SZ
+ *iv_return = DB_HEAP_RID_SZ;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_15 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_APPLY_LOGREG DB_ASSOC_CREATE DB_BACKUP_CLEAN DB_BACKUP_FILES
+ DB_BTREEVERSION DB_BUFFER_SMALL DB_CKP_INTERNAL DB_CONSUME_WAIT
+ DB_ENV_DSYNC_DB DB_ENV_LOCKDOWN DB_ENV_YIELDCPU DB_GET_BOTH_LTE
+ DB_IGNORE_LEASE DB_LOCK_DEFAULT DB_LOCK_INHERIT DB_LOCK_NOTHELD
+ DB_LOCK_PUT_ALL DB_LOCK_PUT_OBJ DB_LOCK_TIMEOUT DB_LOCK_UPGRADE
+ DB_LOG_INMEMORY DB_LOG_WRNOSYNC DB_MPOOL_CREATE DB_MPOOL_EXTENT
+ DB_MPOOL_NOFILE DB_MPOOL_NOLOCK DB_MPOOL_UNLINK DB_MULTIPLE_KEY
+ DB_MULTIVERSION DB_MUTEX_LOCKED DB_MUTEX_SHARED DB_MUTEX_THREAD
+ DB_OPFLAGS_MASK DB_ORDERCHKONLY DB_PRIORITY_LOW DB_REGION_MAGIC
+ DB_REP_ANYWHERE DB_REP_ELECTION DB_REP_LOGREADY DB_REP_LOGSONLY
+ DB_REP_NOBUFFER DB_REP_OUTDATED DB_REP_PAGEDONE DB_STAT_NOERROR
+ DB_STAT_SUMMARY DB_ST_OVFL_LEAF DB_SURPRISE_KID DB_TEST_POSTLOG
+ DB_TEST_PREOPEN DB_TEST_RECYCLE DB_TXN_LOCK_2PL DB_TXN_LOG_MASK
+ DB_TXN_LOG_REDO DB_TXN_LOG_UNDO DB_TXN_SNAPSHOT DB_VERB_FILEOPS
+ DB_VERIFY_FATAL */
+ /* Offset 10 gives the best switch position. */
+ switch (name[10]) {
+ case 'C':
+ if (memEQ(name, "DB_BACKUP_CLEAN", 15)) {
+ /* ^ */
+#ifdef DB_BACKUP_CLEAN
+ *iv_return = DB_BACKUP_CLEAN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_ELECTION", 15)) {
+ /* ^ */
+#ifdef DB_REP_ELECTION
+ *iv_return = DB_REP_ELECTION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_RECYCLE", 15)) {
+ /* ^ */
+#ifdef DB_TEST_RECYCLE
+ *iv_return = DB_TEST_RECYCLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_REP_OUTDATED", 15)) {
+ /* ^ */
+#ifdef DB_REP_OUTDATED
+ *iv_return = DB_REP_OUTDATED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_CKP_INTERNAL", 15)) {
+ /* ^ */
+#ifdef DB_CKP_INTERNAL
+ *iv_return = DB_CKP_INTERNAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_INMEMORY", 15)) {
+ /* ^ */
+#ifdef DB_LOG_INMEMORY
+ *iv_return = DB_LOG_INMEMORY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MULTIPLE_KEY", 15)) {
+ /* ^ */
+#ifdef DB_MULTIPLE_KEY
+ *iv_return = DB_MULTIPLE_KEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_PAGEDONE", 15)) {
+ /* ^ */
+#ifdef DB_REP_PAGEDONE
+ *iv_return = DB_REP_PAGEDONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_NOERROR", 15)) {
+ /* ^ */
+#ifdef DB_STAT_NOERROR
+ *iv_return = DB_STAT_NOERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SURPRISE_KID", 15)) {
+ /* ^ */
+#ifdef DB_SURPRISE_KID
+ *iv_return = DB_SURPRISE_KID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_PREOPEN", 15)) {
+ /* ^ */
+#ifdef DB_TEST_PREOPEN
+ *iv_return = DB_TEST_PREOPEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_BACKUP_FILES", 15)) {
+ /* ^ */
+#ifdef DB_BACKUP_FILES
+ *iv_return = DB_BACKUP_FILES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_DEFAULT", 15)) {
+ /* ^ */
+#ifdef DB_LOCK_DEFAULT
+ *iv_return = DB_LOCK_DEFAULT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERIFY_FATAL", 15)) {
+ /* ^ */
+#ifdef DB_VERIFY_FATAL
+ *iv_return = DB_VERIFY_FATAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_LOCK_UPGRADE", 15)) {
+ /* ^ */
+#ifdef DB_LOCK_UPGRADE
+ *iv_return = DB_LOCK_UPGRADE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_GET_BOTH_LTE", 15)) {
+ /* ^ */
+#ifdef DB_GET_BOTH_LTE
+ *iv_return = DB_GET_BOTH_LTE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_INHERIT", 15)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 7) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 7 && \
+ DB_VERSION_PATCH >= 1)
+ *iv_return = DB_LOCK_INHERIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MUTEX_SHARED", 15)) {
+ /* ^ */
+#ifdef DB_MUTEX_SHARED
+ *iv_return = DB_MUTEX_SHARED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MUTEX_THREAD", 15)) {
+ /* ^ */
+#ifdef DB_MUTEX_THREAD
+ *iv_return = DB_MUTEX_THREAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_ENV_LOCKDOWN", 15)) {
+ /* ^ */
+#ifdef DB_ENV_LOCKDOWN
+ *iv_return = DB_ENV_LOCKDOWN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ORDERCHKONLY", 15)) {
+ /* ^ */
+#ifdef DB_ORDERCHKONLY
+ *iv_return = DB_ORDERCHKONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOCK_2PL", 15)) {
+ /* ^ */
+#ifdef DB_TXN_LOCK_2PL
+ *iv_return = DB_TXN_LOCK_2PL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_ENV_YIELDCPU", 15)) {
+ /* ^ */
+#ifdef DB_ENV_YIELDCPU
+ *iv_return = DB_ENV_YIELDCPU;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_IGNORE_LEASE", 15)) {
+ /* ^ */
+#ifdef DB_IGNORE_LEASE
+ *iv_return = DB_IGNORE_LEASE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_FILEOPS", 15)) {
+ /* ^ */
+#ifdef DB_VERB_FILEOPS
+ *iv_return = DB_VERB_FILEOPS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_LOCK_TIMEOUT", 15)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_LOCK_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REGION_MAGIC", 15)) {
+ /* ^ */
+#ifdef DB_REGION_MAGIC
+ *iv_return = DB_REGION_MAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_SUMMARY", 15)) {
+ /* ^ */
+#ifdef DB_STAT_SUMMARY
+ *iv_return = DB_STAT_SUMMARY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_ENV_DSYNC_DB", 15)) {
+ /* ^ */
+#ifdef DB_ENV_DSYNC_DB
+ *iv_return = DB_ENV_DSYNC_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_UNLINK", 15)) {
+ /* ^ */
+#ifdef DB_MPOOL_UNLINK
+ *iv_return = DB_MPOOL_UNLINK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_APPLY_LOGREG", 15)) {
+ /* ^ */
+#ifdef DB_APPLY_LOGREG
+ *iv_return = DB_APPLY_LOGREG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_WRNOSYNC", 15)) {
+ /* ^ */
+#ifdef DB_LOG_WRNOSYNC
+ *iv_return = DB_LOG_WRNOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_NOFILE", 15)) {
+ /* ^ */
+#ifdef DB_MPOOL_NOFILE
+ *iv_return = DB_MPOOL_NOFILE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_NOLOCK", 15)) {
+ /* ^ */
+#ifdef DB_MPOOL_NOLOCK
+ *iv_return = DB_MPOOL_NOLOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MUTEX_LOCKED", 15)) {
+ /* ^ */
+#ifdef DB_MUTEX_LOCKED
+ *iv_return = DB_MUTEX_LOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_TXN_SNAPSHOT", 15)) {
+ /* ^ */
+#ifdef DB_TXN_SNAPSHOT
+ *iv_return = DB_TXN_SNAPSHOT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_ASSOC_CREATE", 15)) {
+ /* ^ */
+#ifdef DB_ASSOC_CREATE
+ *iv_return = DB_ASSOC_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_BTREEVERSION", 15)) {
+ /* ^ */
+#ifdef DB_BTREEVERSION
+ *iv_return = DB_BTREEVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_CREATE", 15)) {
+ /* ^ */
+#ifdef DB_MPOOL_CREATE
+ *iv_return = DB_MPOOL_CREATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MULTIVERSION", 15)) {
+ /* ^ */
+#ifdef DB_MULTIVERSION
+ *iv_return = DB_MULTIVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_LOGREADY", 15)) {
+ /* ^ */
+#ifdef DB_REP_LOGREADY
+ *iv_return = DB_REP_LOGREADY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_BUFFER_SMALL", 15)) {
+ /* ^ */
+#ifdef DB_BUFFER_SMALL
+ *iv_return = DB_BUFFER_SMALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_LOGSONLY", 15)) {
+ /* ^ */
+#ifdef DB_REP_LOGSONLY
+ *iv_return = DB_REP_LOGSONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_POSTLOG", 15)) {
+ /* ^ */
+#ifdef DB_TEST_POSTLOG
+ *iv_return = DB_TEST_POSTLOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_LOCK_NOTHELD", 15)) {
+ /* ^ */
+#ifdef DB_LOCK_NOTHELD
+ *iv_return = DB_LOCK_NOTHELD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_PUT_ALL", 15)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_LOCK_PUT_ALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_PUT_OBJ", 15)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 2) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 3)
+ *iv_return = DB_LOCK_PUT_OBJ;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_REP_NOBUFFER", 15)) {
+ /* ^ */
+#ifdef DB_REP_NOBUFFER
+ *iv_return = DB_REP_NOBUFFER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_REP_ANYWHERE", 15)) {
+ /* ^ */
+#ifdef DB_REP_ANYWHERE
+ *iv_return = DB_REP_ANYWHERE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB_MPOOL_EXTENT", 15)) {
+ /* ^ */
+#ifdef DB_MPOOL_EXTENT
+ *iv_return = DB_MPOOL_EXTENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_PRIORITY_LOW", 15)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_PRIORITY_LOW;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_CONSUME_WAIT", 15)) {
+ /* ^ */
+#ifdef DB_CONSUME_WAIT
+ *iv_return = DB_CONSUME_WAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OPFLAGS_MASK", 15)) {
+ /* ^ */
+#ifdef DB_OPFLAGS_MASK
+ *iv_return = DB_OPFLAGS_MASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ST_OVFL_LEAF", 15)) {
+ /* ^ */
+#ifdef DB_ST_OVFL_LEAF
+ *iv_return = DB_ST_OVFL_LEAF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOG_MASK", 15)) {
+ /* ^ */
+#ifdef DB_TXN_LOG_MASK
+ *iv_return = DB_TXN_LOG_MASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOG_REDO", 15)) {
+ /* ^ */
+#ifdef DB_TXN_LOG_REDO
+ *iv_return = DB_TXN_LOG_REDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOG_UNDO", 15)) {
+ /* ^ */
+#ifdef DB_TXN_LOG_UNDO
+ *iv_return = DB_TXN_LOG_UNDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_16 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_BACKUP_UPDATE DB_CACHED_COUNTS DB_COMPACT_FLAGS DB_DATABASE_LOCK
+ DB_EID_BROADCAST DB_ENV_CDB_ALLDB DB_ENV_DIRECT_DB DB_ENV_DSYNC_LOG
+ DB_ENV_HOTBACKUP DB_ENV_NOLOCKING DB_ENV_OVERWRITE DB_ENV_RPCCLIENT
+ DB_FCNTL_LOCKING DB_FOREIGN_ABORT DB_FREELIST_ONLY DB_GROUP_CREATOR
+ DB_IMMUTABLE_KEY DB_JAVA_CALLBACK DB_LOCK_CONFLICT DB_LOCK_DEADLOCK
+ DB_LOCK_MAXLOCKS DB_LOCK_MAXWRITE DB_LOCK_MINLOCKS DB_LOCK_MINWRITE
+ DB_LOCK_NOTEXIST DB_LOCK_PUT_READ DB_LOCK_YOUNGEST DB_LOGC_BUF_SIZE
+ DB_LOG_IN_MEMORY DB_MPOOL_DISCARD DB_MPOOL_PRIVATE DB_NOSERVER_HOME
+ DB_NO_CHECKPOINT DB_OVERWRITE_DUP DB_PAGE_NOTFOUND DB_PRIORITY_HIGH
+ DB_RECOVER_FATAL DB_REPFLAGS_MASK DB_REPMGR_ISPEER DB_REP_CONF_BULK
+ DB_REP_DUPMASTER DB_REP_NEWMASTER DB_REP_PERMANENT DB_REP_REREQUEST
+ DB_SA_UNKNOWNKEY DB_SECONDARY_BAD DB_SEQ_RANGE_SET DB_TEST_POSTOPEN
+ DB_TEST_POSTSYNC DB_TXN_LOCK_MASK DB_TXN_OPENFILES DB_VERB_CHKPOINT
+ DB_VERB_DEADLOCK DB_VERB_RECOVERY DB_VERB_REGISTER DB_VERB_REP_MISC
+ DB_VERB_REP_MSGS DB_VERB_REP_SYNC DB_VERB_REP_TEST DB_VERB_WAITSFOR
+ DB_VERSION_MAJOR DB_VERSION_MINOR DB_VERSION_PATCH DB_VRFY_FLAGMASK */
+ /* Offset 10 gives the best switch position. */
+ switch (name[10]) {
+ case 'A':
+ if (memEQ(name, "DB_EID_BROADCAST", 16)) {
+ /* ^ */
+#ifdef DB_EID_BROADCAST
+ *iv_return = DB_EID_BROADCAST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_DEADLOCK", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_DEADLOCK
+ *iv_return = DB_LOCK_DEADLOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_DEADLOCK", 16)) {
+ /* ^ */
+#ifdef DB_VERB_DEADLOCK
+ *iv_return = DB_VERB_DEADLOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VRFY_FLAGMASK", 16)) {
+ /* ^ */
+#ifdef DB_VRFY_FLAGMASK
+ *iv_return = DB_VRFY_FLAGMASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "DB_ENV_HOTBACKUP", 16)) {
+ /* ^ */
+#ifdef DB_ENV_HOTBACKUP
+ *iv_return = DB_ENV_HOTBACKUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_CACHED_COUNTS", 16)) {
+ /* ^ */
+#ifdef DB_CACHED_COUNTS
+ *iv_return = DB_CACHED_COUNTS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_RPCCLIENT", 16)) {
+ /* ^ */
+#ifdef DB_ENV_RPCCLIENT
+ *iv_return = DB_ENV_RPCCLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_RECOVERY", 16)) {
+ /* ^ */
+#ifdef DB_VERB_RECOVERY
+ *iv_return = DB_VERB_RECOVERY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_DATABASE_LOCK", 16)) {
+ /* ^ */
+#ifdef DB_DATABASE_LOCK
+ *iv_return = DB_DATABASE_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_DIRECT_DB", 16)) {
+ /* ^ */
+#ifdef DB_ENV_DIRECT_DB
+ *iv_return = DB_ENV_DIRECT_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_REREQUEST", 16)) {
+ /* ^ */
+#ifdef DB_REP_REREQUEST
+ *iv_return = DB_REP_REREQUEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_LOGC_BUF_SIZE", 16)) {
+ /* ^ */
+#ifdef DB_LOGC_BUF_SIZE
+ *iv_return = DB_LOGC_BUF_SIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_CONF_BULK", 16)) {
+ /* ^ */
+#ifdef DB_REP_CONF_BULK
+ *iv_return = DB_REP_CONF_BULK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_SEQ_RANGE_SET", 16)) {
+ /* ^ */
+#ifdef DB_SEQ_RANGE_SET
+ *iv_return = DB_SEQ_RANGE_SET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REGISTER", 16)) {
+ /* ^ */
+#ifdef DB_VERB_REGISTER
+ *iv_return = DB_VERB_REGISTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_MPOOL_DISCARD", 16)) {
+ /* ^ */
+#ifdef DB_MPOOL_DISCARD
+ *iv_return = DB_MPOOL_DISCARD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_ISPEER", 16)) {
+ /* ^ */
+#ifdef DB_REPMGR_ISPEER
+ *iv_return = DB_REPMGR_ISPEER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_WAITSFOR", 16)) {
+ /* ^ */
+#ifdef DB_VERB_WAITSFOR
+ *iv_return = DB_VERB_WAITSFOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_NO_CHECKPOINT", 16)) {
+ /* ^ */
+#ifdef DB_NO_CHECKPOINT
+ *iv_return = DB_NO_CHECKPOINT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOCK_MASK", 16)) {
+ /* ^ */
+#ifdef DB_TXN_LOCK_MASK
+ *iv_return = DB_TXN_LOCK_MASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_CHKPOINT", 16)) {
+ /* ^ */
+#ifdef DB_VERB_CHKPOINT
+ *iv_return = DB_VERB_CHKPOINT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_IMMUTABLE_KEY", 16)) {
+ /* ^ */
+#ifdef DB_IMMUTABLE_KEY
+ *iv_return = DB_IMMUTABLE_KEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_JAVA_CALLBACK", 16)) {
+ /* ^ */
+#ifdef DB_JAVA_CALLBACK
+ *iv_return = DB_JAVA_CALLBACK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_LOG_IN_MEMORY", 16)) {
+ /* ^ */
+#ifdef DB_LOG_IN_MEMORY
+ *iv_return = DB_LOG_IN_MEMORY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_DUPMASTER", 16)) {
+ /* ^ */
+#ifdef DB_REP_DUPMASTER
+ *iv_return = DB_REP_DUPMASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_NEWMASTER", 16)) {
+ /* ^ */
+#ifdef DB_REP_NEWMASTER
+ *iv_return = DB_REP_NEWMASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_PERMANENT", 16)) {
+ /* ^ */
+#ifdef DB_REP_PERMANENT
+ *iv_return = DB_REP_PERMANENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_ENV_DSYNC_LOG", 16)) {
+ /* ^ */
+#ifdef DB_ENV_DSYNC_LOG
+ *iv_return = DB_ENV_DSYNC_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_CONFLICT", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_CONFLICT
+ *iv_return = DB_LOCK_CONFLICT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_MINLOCKS", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_MINLOCKS
+ *iv_return = DB_LOCK_MINLOCKS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_MINWRITE", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_MINWRITE
+ *iv_return = DB_LOCK_MINWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_OPENFILES", 16)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 3) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_OPENFILES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_ENV_NOLOCKING", 16)) {
+ /* ^ */
+#ifdef DB_ENV_NOLOCKING
+ *iv_return = DB_ENV_NOLOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FCNTL_LOCKING", 16)) {
+ /* ^ */
+#ifdef DB_FCNTL_LOCKING
+ *iv_return = DB_FCNTL_LOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SA_UNKNOWNKEY", 16)) {
+ /* ^ */
+#ifdef DB_SA_UNKNOWNKEY
+ *iv_return = DB_SA_UNKNOWNKEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_VERB_REP_MISC", 16)) {
+ /* ^ */
+#ifdef DB_VERB_REP_MISC
+ *iv_return = DB_VERB_REP_MISC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_MSGS", 16)) {
+ /* ^ */
+#ifdef DB_VERB_REP_MSGS
+ *iv_return = DB_VERB_REP_MSGS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_SYNC", 16)) {
+ /* ^ */
+#ifdef DB_VERB_REP_SYNC
+ *iv_return = DB_VERB_REP_SYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_TEST", 16)) {
+ /* ^ */
+#ifdef DB_VERB_REP_TEST
+ *iv_return = DB_VERB_REP_TEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_ENV_OVERWRITE", 16)) {
+ /* ^ */
+#ifdef DB_ENV_OVERWRITE
+ *iv_return = DB_ENV_OVERWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_GROUP_CREATOR", 16)) {
+ /* ^ */
+#ifdef DB_GROUP_CREATOR
+ *iv_return = DB_GROUP_CREATOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MPOOL_PRIVATE", 16)) {
+ /* ^ */
+#ifdef DB_MPOOL_PRIVATE
+ *iv_return = DB_MPOOL_PRIVATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NOSERVER_HOME", 16)) {
+ /* ^ */
+#ifdef DB_NOSERVER_HOME
+ *iv_return = DB_NOSERVER_HOME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SECONDARY_BAD", 16)) {
+ /* ^ */
+#ifdef DB_SECONDARY_BAD
+ *iv_return = DB_SECONDARY_BAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_REPFLAGS_MASK", 16)) {
+ /* ^ */
+#ifdef DB_REPFLAGS_MASK
+ *iv_return = DB_REPFLAGS_MASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_POSTOPEN", 16)) {
+ /* ^ */
+#ifdef DB_TEST_POSTOPEN
+ *iv_return = DB_TEST_POSTOPEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_POSTSYNC", 16)) {
+ /* ^ */
+#ifdef DB_TEST_POSTSYNC
+ *iv_return = DB_TEST_POSTSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_FREELIST_ONLY", 16)) {
+ /* ^ */
+#ifdef DB_FREELIST_ONLY
+ *iv_return = DB_FREELIST_ONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_NOTEXIST", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_NOTEXIST
+ *iv_return = DB_LOCK_NOTEXIST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_PUT_READ", 16)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_LOCK_PUT_READ;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_OVERWRITE_DUP", 16)) {
+ /* ^ */
+#ifdef DB_OVERWRITE_DUP
+ *iv_return = DB_OVERWRITE_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PAGE_NOTFOUND", 16)) {
+ /* ^ */
+#ifdef DB_PAGE_NOTFOUND
+ *iv_return = DB_PAGE_NOTFOUND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_BACKUP_UPDATE", 16)) {
+ /* ^ */
+#ifdef DB_BACKUP_UPDATE
+ *iv_return = DB_BACKUP_UPDATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_YOUNGEST", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_YOUNGEST
+ *iv_return = DB_LOCK_YOUNGEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'X':
+ if (memEQ(name, "DB_LOCK_MAXLOCKS", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_MAXLOCKS
+ *iv_return = DB_LOCK_MAXLOCKS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_MAXWRITE", 16)) {
+ /* ^ */
+#ifdef DB_LOCK_MAXWRITE
+ *iv_return = DB_LOCK_MAXWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_PRIORITY_HIGH", 16)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_PRIORITY_HIGH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_COMPACT_FLAGS", 16)) {
+ /* ^ */
+#ifdef DB_COMPACT_FLAGS
+ *iv_return = DB_COMPACT_FLAGS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_CDB_ALLDB", 16)) {
+ /* ^ */
+#ifdef DB_ENV_CDB_ALLDB
+ *iv_return = DB_ENV_CDB_ALLDB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FOREIGN_ABORT", 16)) {
+ /* ^ */
+#ifdef DB_FOREIGN_ABORT
+ *iv_return = DB_FOREIGN_ABORT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_RECOVER_FATAL", 16)) {
+ /* ^ */
+#ifdef DB_RECOVER_FATAL
+ *iv_return = DB_RECOVER_FATAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_MAJOR", 16)) {
+ /* ^ */
+#ifdef DB_VERSION_MAJOR
+ *iv_return = DB_VERSION_MAJOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_MINOR", 16)) {
+ /* ^ */
+#ifdef DB_VERSION_MINOR
+ *iv_return = DB_VERSION_MINOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_PATCH", 16)) {
+ /* ^ */
+#ifdef DB_VERSION_PATCH
+ *iv_return = DB_VERSION_PATCH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_17 (pTHX_ const char *name, IV *iv_return, const char **pv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_BACKUP_NO_LOGS DB_ENV_DIRECT_LOG DB_ENV_REP_CLIENT DB_ENV_REP_MASTER
+ DB_ENV_STANDALONE DB_ENV_SYSTEM_MEM DB_ENV_TXN_NOSYNC DB_ENV_TXN_NOWAIT
+ DB_ENV_USER_ALLOC DB_GET_BOTH_RANGE DB_LOG_AUTOREMOVE DB_LOG_SILENT_ERR
+ DB_LOG_VERIFY_BAD DB_LOG_VERIFY_CAF DB_LOG_VERIFY_ERR DB_MEM_LOCKOBJECT
+ DB_NO_AUTO_COMMIT DB_READ_COMMITTED DB_REP_CONF_INMEM DB_REP_CONF_LEASE
+ DB_REP_PAGELOCKED DB_RPC_SERVERPROG DB_RPC_SERVERVERS DB_STAT_LOCK_CONF
+ DB_STAT_MEMP_HASH DB_STAT_SUBSYSTEM DB_TEST_ELECTINIT DB_TEST_ELECTSEND
+ DB_TEST_PRERENAME DB_TXN_LOG_VERIFY DB_TXN_POPENFILES DB_TXN_TOKEN_SIZE
+ DB_VERB_REP_ELECT DB_VERB_REP_LEASE DB_VERSION_FAMILY DB_VERSION_STRING */
+ /* Offset 13 gives the best switch position. */
+ switch (name[13]) {
+ case 'A':
+ if (memEQ(name, "DB_GET_BOTH_RANGE", 17)) {
+ /* ^ */
+#ifdef DB_GET_BOTH_RANGE
+ *iv_return = DB_GET_BOTH_RANGE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_REP_PAGELOCKED", 17)) {
+ /* ^ */
+#ifdef DB_REP_PAGELOCKED
+ *iv_return = DB_REP_PAGELOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_LOCK_CONF", 17)) {
+ /* ^ */
+#ifdef DB_STAT_LOCK_CONF
+ *iv_return = DB_STAT_LOCK_CONF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_REP_CONF_LEASE", 17)) {
+ /* ^ */
+#ifdef DB_REP_CONF_LEASE
+ *iv_return = DB_REP_CONF_LEASE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_LEASE", 17)) {
+ /* ^ */
+#ifdef DB_VERB_REP_LEASE
+ *iv_return = DB_VERB_REP_LEASE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_STAT_MEMP_HASH", 17)) {
+ /* ^ */
+#ifdef DB_STAT_MEMP_HASH
+ *iv_return = DB_STAT_MEMP_HASH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_ENV_REP_CLIENT", 17)) {
+ /* ^ */
+#ifdef DB_ENV_REP_CLIENT
+ *iv_return = DB_ENV_REP_CLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_ELECTINIT", 17)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTINIT
+ *iv_return = DB_TEST_ELECTINIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_POPENFILES", 17)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_POPENFILES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'J':
+ if (memEQ(name, "DB_MEM_LOCKOBJECT", 17)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_LOCKOBJECT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_BACKUP_NO_LOGS", 17)) {
+ /* ^ */
+#ifdef DB_BACKUP_NO_LOGS
+ *iv_return = DB_BACKUP_NO_LOGS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_STANDALONE", 17)) {
+ /* ^ */
+#ifdef DB_ENV_STANDALONE
+ *iv_return = DB_ENV_STANDALONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_USER_ALLOC", 17)) {
+ /* ^ */
+#ifdef DB_ENV_USER_ALLOC
+ *iv_return = DB_ENV_USER_ALLOC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_ELECT", 17)) {
+ /* ^ */
+#ifdef DB_VERB_REP_ELECT
+ *iv_return = DB_VERB_REP_ELECT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_LOG_AUTOREMOVE", 17)) {
+ /* ^ */
+#ifdef DB_LOG_AUTOREMOVE
+ *iv_return = DB_LOG_AUTOREMOVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_NO_AUTO_COMMIT", 17)) {
+ /* ^ */
+#ifdef DB_NO_AUTO_COMMIT
+ *iv_return = DB_NO_AUTO_COMMIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_FAMILY", 17)) {
+ /* ^ */
+#ifdef DB_VERSION_FAMILY
+ *iv_return = DB_VERSION_FAMILY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_REP_CONF_INMEM", 17)) {
+ /* ^ */
+#ifdef DB_REP_CONF_INMEM
+ *iv_return = DB_REP_CONF_INMEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_PRERENAME", 17)) {
+ /* ^ */
+#ifdef DB_TEST_PRERENAME
+ *iv_return = DB_TEST_PRERENAME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_RPC_SERVERPROG", 17)) {
+ /* ^ */
+#ifdef DB_RPC_SERVERPROG
+ *iv_return = DB_RPC_SERVERPROG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_TXN_LOG_VERIFY", 17)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 6)
+ *iv_return = DB_TXN_LOG_VERIFY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_STRING", 17)) {
+ /* ^ */
+#ifdef DB_VERSION_STRING
+ *pv_return = DB_VERSION_STRING;
+ return PERL_constant_ISPV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_ENV_REP_MASTER", 17)) {
+ /* ^ */
+#ifdef DB_ENV_REP_MASTER
+ *iv_return = DB_ENV_REP_MASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_TXN_NOSYNC", 17)) {
+ /* ^ */
+#ifdef DB_ENV_TXN_NOSYNC
+ *iv_return = DB_ENV_TXN_NOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_SUBSYSTEM", 17)) {
+ /* ^ */
+#ifdef DB_STAT_SUBSYSTEM
+ *iv_return = DB_STAT_SUBSYSTEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_ELECTSEND", 17)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTSEND
+ *iv_return = DB_TEST_ELECTSEND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_TOKEN_SIZE", 17)) {
+ /* ^ */
+#ifdef DB_TXN_TOKEN_SIZE
+ *iv_return = DB_TXN_TOKEN_SIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_READ_COMMITTED", 17)) {
+ /* ^ */
+#ifdef DB_READ_COMMITTED
+ *iv_return = DB_READ_COMMITTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'V':
+ if (memEQ(name, "DB_RPC_SERVERVERS", 17)) {
+ /* ^ */
+#ifdef DB_RPC_SERVERVERS
+ *iv_return = DB_RPC_SERVERVERS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_ENV_TXN_NOWAIT", 17)) {
+ /* ^ */
+#ifdef DB_ENV_TXN_NOWAIT
+ *iv_return = DB_ENV_TXN_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_ENV_DIRECT_LOG", 17)) {
+ /* ^ */
+#ifdef DB_ENV_DIRECT_LOG
+ *iv_return = DB_ENV_DIRECT_LOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_SYSTEM_MEM", 17)) {
+ /* ^ */
+#ifdef DB_ENV_SYSTEM_MEM
+ *iv_return = DB_ENV_SYSTEM_MEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_SILENT_ERR", 17)) {
+ /* ^ */
+#ifdef DB_LOG_SILENT_ERR
+ *iv_return = DB_LOG_SILENT_ERR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_VERIFY_BAD", 17)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_BAD
+ *iv_return = DB_LOG_VERIFY_BAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_VERIFY_CAF", 17)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_CAF
+ *iv_return = DB_LOG_VERIFY_CAF;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_VERIFY_ERR", 17)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_ERR
+ *iv_return = DB_LOG_VERIFY_ERR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_18 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_ALREADY_ABORTED DB_DURABLE_UNKNOWN DB_ENV_AUTO_COMMIT
+ DB_ENV_OPEN_CALLED DB_ENV_REF_COUNTED DB_ENV_REGION_INIT
+ DB_EVENT_REG_ALIVE DB_EVENT_REG_PANIC DB_FAILCHK_ISALIVE
+ DB_FOREIGN_CASCADE DB_FOREIGN_NULLIFY DB_LOCK_IGNORE_REC
+ DB_LOCK_NOTGRANTED DB_LOG_AUTO_REMOVE DB_LOG_BUFFER_FULL
+ DB_LOG_NOT_DURABLE DB_MEM_TRANSACTION DB_MPOOL_NEW_GROUP
+ DB_MUTEX_ALLOCATED DB_PR_RECOVERYTEST DB_REPMGR_ACKS_ALL
+ DB_REPMGR_ACKS_ONE DB_REP_ACK_TIMEOUT DB_REP_CONF_NOWAIT
+ DB_REP_HANDLE_DEAD DB_REP_STARTUPDONE DB_SA_SKIPFIRSTKEY
+ DB_SEQUENCE_OLDVER DB_SET_REG_TIMEOUT DB_SET_TXN_TIMEOUT
+ DB_TEST_ELECTVOTE1 DB_TEST_ELECTVOTE2 DB_TEST_ELECTWAIT1
+ DB_TEST_ELECTWAIT2 DB_TEST_POSTRENAME DB_TEST_PREDESTROY
+ DB_THREADID_STRLEN DB_TIME_NOTGRANTED DB_TXN_NOT_DURABLE
+ DB_VERB_REP_SYSTEM DB_VERSION_RELEASE */
+ /* Offset 13 gives the best switch position. */
+ switch (name[13]) {
+ case 'A':
+ if (memEQ(name, "DB_ENV_OPEN_CALLED", 18)) {
+ /* ^ */
+#ifdef DB_ENV_OPEN_CALLED
+ *iv_return = DB_ENV_OPEN_CALLED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_EVENT_REG_ALIVE", 18)) {
+ /* ^ */
+#ifdef DB_EVENT_REG_ALIVE
+ *iv_return = DB_EVENT_REG_ALIVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_FAILCHK_ISALIVE", 18)) {
+ /* ^ */
+#ifdef DB_FAILCHK_ISALIVE
+ *iv_return = DB_FAILCHK_ISALIVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_NOTGRANTED", 18)) {
+ /* ^ */
+#ifdef DB_LOCK_NOTGRANTED
+ *iv_return = DB_LOCK_NOTGRANTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TIME_NOTGRANTED", 18)) {
+ /* ^ */
+#ifdef DB_TIME_NOTGRANTED
+ *iv_return = DB_TIME_NOTGRANTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_MEM_TRANSACTION", 18)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_MEM_TRANSACTION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_MUTEX_ALLOCATED", 18)) {
+ /* ^ */
+#ifdef DB_MUTEX_ALLOCATED
+ *iv_return = DB_MUTEX_ALLOCATED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_LOCK_IGNORE_REC", 18)) {
+ /* ^ */
+#ifdef DB_LOCK_IGNORE_REC
+ *iv_return = DB_LOCK_IGNORE_REC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_AUTO_REMOVE", 18)) {
+ /* ^ */
+#ifdef DB_LOG_AUTO_REMOVE
+ *iv_return = DB_LOG_AUTO_REMOVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_POSTRENAME", 18)) {
+ /* ^ */
+#ifdef DB_TEST_POSTRENAME
+ *iv_return = DB_TEST_POSTRENAME;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_MPOOL_NEW_GROUP", 18)) {
+ /* ^ */
+#ifdef DB_MPOOL_NEW_GROUP
+ *iv_return = DB_MPOOL_NEW_GROUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_DURABLE_UNKNOWN", 18)) {
+ /* ^ */
+#ifdef DB_DURABLE_UNKNOWN
+ *iv_return = DB_DURABLE_UNKNOWN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_FOREIGN_NULLIFY", 18)) {
+ /* ^ */
+#ifdef DB_FOREIGN_NULLIFY
+ *iv_return = DB_FOREIGN_NULLIFY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQUENCE_OLDVER", 18)) {
+ /* ^ */
+#ifdef DB_SEQUENCE_OLDVER
+ *iv_return = DB_SEQUENCE_OLDVER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_RELEASE", 18)) {
+ /* ^ */
+#ifdef DB_VERSION_RELEASE
+ *iv_return = DB_VERSION_RELEASE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_REP_ACK_TIMEOUT", 18)) {
+ /* ^ */
+#ifdef DB_REP_ACK_TIMEOUT
+ *iv_return = DB_REP_ACK_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SET_REG_TIMEOUT", 18)) {
+ /* ^ */
+#ifdef DB_SET_REG_TIMEOUT
+ *iv_return = DB_SET_REG_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SET_TXN_TIMEOUT", 18)) {
+ /* ^ */
+#ifdef DB_SET_TXN_TIMEOUT
+ *iv_return = DB_SET_TXN_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_ALREADY_ABORTED", 18)) {
+ /* ^ */
+#ifdef DB_ALREADY_ABORTED
+ *iv_return = DB_ALREADY_ABORTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_AUTO_COMMIT", 18)) {
+ /* ^ */
+#ifdef DB_ENV_AUTO_COMMIT
+ *iv_return = DB_ENV_AUTO_COMMIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_CONF_NOWAIT", 18)) {
+ /* ^ */
+#ifdef DB_REP_CONF_NOWAIT
+ *iv_return = DB_REP_CONF_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_EVENT_REG_PANIC", 18)) {
+ /* ^ */
+#ifdef DB_EVENT_REG_PANIC
+ *iv_return = DB_EVENT_REG_PANIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_STARTUPDONE", 18)) {
+ /* ^ */
+#ifdef DB_REP_STARTUPDONE
+ *iv_return = DB_REP_STARTUPDONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_LOG_NOT_DURABLE", 18)) {
+ /* ^ */
+#ifdef DB_LOG_NOT_DURABLE
+ *iv_return = DB_LOG_NOT_DURABLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_NOT_DURABLE", 18)) {
+ /* ^ */
+#ifdef DB_TXN_NOT_DURABLE
+ *iv_return = DB_TXN_NOT_DURABLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_FOREIGN_CASCADE", 18)) {
+ /* ^ */
+#ifdef DB_FOREIGN_CASCADE
+ *iv_return = DB_FOREIGN_CASCADE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_ACKS_ALL", 18)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_ALL
+ *iv_return = DB_REPMGR_ACKS_ALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_ACKS_ONE", 18)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_ONE
+ *iv_return = DB_REPMGR_ACKS_ONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SA_SKIPFIRSTKEY", 18)) {
+ /* ^ */
+#ifdef DB_SA_SKIPFIRSTKEY
+ *iv_return = DB_SA_SKIPFIRSTKEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_PREDESTROY", 18)) {
+ /* ^ */
+#ifdef DB_TEST_PREDESTROY
+ *iv_return = DB_TEST_PREDESTROY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_THREADID_STRLEN", 18)) {
+ /* ^ */
+#ifdef DB_THREADID_STRLEN
+ *iv_return = DB_THREADID_STRLEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_ENV_REF_COUNTED", 18)) {
+ /* ^ */
+#ifdef DB_ENV_REF_COUNTED
+ *iv_return = DB_ENV_REF_COUNTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'V':
+ if (memEQ(name, "DB_TEST_ELECTVOTE1", 18)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTVOTE1
+ *iv_return = DB_TEST_ELECTVOTE1;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_ELECTVOTE2", 18)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTVOTE2
+ *iv_return = DB_TEST_ELECTVOTE2;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_TEST_ELECTWAIT1", 18)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTWAIT1
+ *iv_return = DB_TEST_ELECTWAIT1;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_ELECTWAIT2", 18)) {
+ /* ^ */
+#ifdef DB_TEST_ELECTWAIT2
+ *iv_return = DB_TEST_ELECTWAIT2;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_PR_RECOVERYTEST", 18)) {
+ /* ^ */
+#ifdef DB_PR_RECOVERYTEST
+ *iv_return = DB_PR_RECOVERYTEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REP_SYSTEM", 18)) {
+ /* ^ */
+#ifdef DB_VERB_REP_SYSTEM
+ *iv_return = DB_VERB_REP_SYSTEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_ENV_REGION_INIT", 18)) {
+ /* ^ */
+#ifdef DB_ENV_REGION_INIT
+ *iv_return = DB_ENV_REGION_INIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_BUFFER_FULL", 18)) {
+ /* ^ */
+#ifdef DB_LOG_BUFFER_FULL
+ *iv_return = DB_LOG_BUFFER_FULL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_HANDLE_DEAD", 18)) {
+ /* ^ */
+#ifdef DB_REP_HANDLE_DEAD
+ *iv_return = DB_REP_HANDLE_DEAD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_19 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_BOOTSTRAP_HELPER DB_CURSOR_TRANSIENT DB_DATABASE_LOCKING
+ DB_ENV_LOG_INMEMORY DB_ENV_MULTIVERSION DB_ENV_REP_LOGSONLY
+ DB_ENV_TXN_SNAPSHOT DB_EVENT_REP_CLIENT DB_EVENT_REP_MASTER
+ DB_FOREIGN_CONFLICT DB_LOCK_FREE_LOCKER DB_LOCK_GET_TIMEOUT
+ DB_LOCK_SET_TIMEOUT DB_MUTEX_SELF_BLOCK DB_PRIORITY_DEFAULT
+ DB_READ_UNCOMMITTED DB_REPMGR_ACKS_NONE DB_REPMGR_CONNECTED
+ DB_REP_HOLDELECTION DB_REP_JOIN_FAILURE DB_SEQUENCE_VERSION
+ DB_SET_LOCK_TIMEOUT DB_STAT_LOCK_PARAMS DB_TEST_POSTDESTROY
+ DB_TEST_POSTLOGMETA DB_TEST_SUBDB_LOCKS DB_TXN_FORWARD_ROLL
+ DB_TXN_LOG_UNDOREDO DB_TXN_WRITE_NOSYNC DB_UPDATE_SECONDARY
+ DB_USERCOPY_GETDATA DB_USERCOPY_SETDATA DB_USE_ENVIRON_ROOT
+ DB_VERB_FILEOPS_ALL DB_VERB_REPLICATION DB_VERB_REPMGR_MISC
+ DB_VERIFY_PARTITION DB_VERSION_MISMATCH */
+ /* Offset 14 gives the best switch position. */
+ switch (name[14]) {
+ case 'A':
+ if (memEQ(name, "DB_EVENT_REP_MASTER", 19)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_MASTER
+ *iv_return = DB_EVENT_REP_MASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_LOCK_PARAMS", 19)) {
+ /* ^ */
+#ifdef DB_STAT_LOCK_PARAMS
+ *iv_return = DB_STAT_LOCK_PARAMS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REPLICATION", 19)) {
+ /* ^ */
+#ifdef DB_VERB_REPLICATION
+ *iv_return = DB_VERB_REPLICATION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "DB_MUTEX_SELF_BLOCK", 19)) {
+ /* ^ */
+#ifdef DB_MUTEX_SELF_BLOCK
+ *iv_return = DB_MUTEX_SELF_BLOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_DATABASE_LOCKING", 19)) {
+ /* ^ */
+#ifdef DB_DATABASE_LOCKING
+ *iv_return = DB_DATABASE_LOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_HOLDELECTION", 19)) {
+ /* ^ */
+#ifdef DB_REP_HOLDELECTION
+ *iv_return = DB_REP_HOLDELECTION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_BOOTSTRAP_HELPER", 19)) {
+ /* ^ */
+#ifdef DB_BOOTSTRAP_HELPER
+ *iv_return = DB_BOOTSTRAP_HELPER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_LOG_INMEMORY", 19)) {
+ /* ^ */
+#ifdef DB_ENV_LOG_INMEMORY
+ *iv_return = DB_ENV_LOG_INMEMORY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_CONNECTED", 19)) {
+ /* ^ */
+#ifdef DB_REPMGR_CONNECTED
+ *iv_return = DB_REPMGR_CONNECTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_FOREIGN_CONFLICT", 19)) {
+ /* ^ */
+#ifdef DB_FOREIGN_CONFLICT
+ *iv_return = DB_FOREIGN_CONFLICT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PRIORITY_DEFAULT", 19)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_PRIORITY_DEFAULT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_TEST_POSTLOGMETA", 19)) {
+ /* ^ */
+#ifdef DB_TEST_POSTLOGMETA
+ *iv_return = DB_TEST_POSTLOGMETA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_READ_UNCOMMITTED", 19)) {
+ /* ^ */
+#ifdef DB_READ_UNCOMMITTED
+ *iv_return = DB_READ_UNCOMMITTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_JOIN_FAILURE", 19)) {
+ /* ^ */
+#ifdef DB_REP_JOIN_FAILURE
+ *iv_return = DB_REP_JOIN_FAILURE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERIFY_PARTITION", 19)) {
+ /* ^ */
+#ifdef DB_VERIFY_PARTITION
+ *iv_return = DB_VERIFY_PARTITION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_EVENT_REP_CLIENT", 19)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_CLIENT
+ *iv_return = DB_EVENT_REP_CLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_SUBDB_LOCKS", 19)) {
+ /* ^ */
+#ifdef DB_TEST_SUBDB_LOCKS
+ *iv_return = DB_TEST_SUBDB_LOCKS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_LOCK_GET_TIMEOUT", 19)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_LOCK_GET_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOCK_SET_TIMEOUT", 19)) {
+ /* ^ */
+#ifdef DB_LOCK_SET_TIMEOUT
+ *iv_return = DB_LOCK_SET_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SET_LOCK_TIMEOUT", 19)) {
+ /* ^ */
+#ifdef DB_SET_LOCK_TIMEOUT
+ *iv_return = DB_SET_LOCK_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_MISMATCH", 19)) {
+ /* ^ */
+#ifdef DB_VERSION_MISMATCH
+ *iv_return = DB_VERSION_MISMATCH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_UPDATE_SECONDARY", 19)) {
+ /* ^ */
+#ifdef DB_UPDATE_SECONDARY
+ *iv_return = DB_UPDATE_SECONDARY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_LOCK_FREE_LOCKER", 19)) {
+ /* ^ */
+#ifdef DB_LOCK_FREE_LOCKER
+ *iv_return = DB_LOCK_FREE_LOCKER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOG_UNDOREDO", 19)) {
+ /* ^ */
+#ifdef DB_TXN_LOG_UNDOREDO
+ *iv_return = DB_TXN_LOG_UNDOREDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_WRITE_NOSYNC", 19)) {
+ /* ^ */
+#ifdef DB_TXN_WRITE_NOSYNC
+ *iv_return = DB_TXN_WRITE_NOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_ENV_TXN_SNAPSHOT", 19)) {
+ /* ^ */
+#ifdef DB_ENV_TXN_SNAPSHOT
+ *iv_return = DB_ENV_TXN_SNAPSHOT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_ENV_MULTIVERSION", 19)) {
+ /* ^ */
+#ifdef DB_ENV_MULTIVERSION
+ *iv_return = DB_ENV_MULTIVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_SEQUENCE_VERSION", 19)) {
+ /* ^ */
+#ifdef DB_SEQUENCE_VERSION
+ *iv_return = DB_SEQUENCE_VERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_CURSOR_TRANSIENT", 19)) {
+ /* ^ */
+#ifdef DB_CURSOR_TRANSIENT
+ *iv_return = DB_CURSOR_TRANSIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_REP_LOGSONLY", 19)) {
+ /* ^ */
+#ifdef DB_ENV_REP_LOGSONLY
+ *iv_return = DB_ENV_REP_LOGSONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TEST_POSTDESTROY", 19)) {
+ /* ^ */
+#ifdef DB_TEST_POSTDESTROY
+ *iv_return = DB_TEST_POSTDESTROY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_FILEOPS_ALL", 19)) {
+ /* ^ */
+#ifdef DB_VERB_FILEOPS_ALL
+ *iv_return = DB_VERB_FILEOPS_ALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_USERCOPY_GETDATA", 19)) {
+ /* ^ */
+#ifdef DB_USERCOPY_GETDATA
+ *iv_return = DB_USERCOPY_GETDATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_USERCOPY_SETDATA", 19)) {
+ /* ^ */
+#ifdef DB_USERCOPY_SETDATA
+ *iv_return = DB_USERCOPY_SETDATA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_REPMGR_ACKS_NONE", 19)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_NONE
+ *iv_return = DB_REPMGR_ACKS_NONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_FORWARD_ROLL", 19)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 3) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_FORWARD_ROLL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_USE_ENVIRON_ROOT", 19)) {
+ /* ^ */
+#ifdef DB_USE_ENVIRON_ROOT
+ *iv_return = DB_USE_ENVIRON_ROOT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERB_REPMGR_MISC", 19)) {
+ /* ^ */
+#ifdef DB_VERB_REPMGR_MISC
+ *iv_return = DB_VERB_REPMGR_MISC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_20 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_BACKUP_READ_COUNT DB_BACKUP_READ_SLEEP DB_BACKUP_SINGLE_DIR
+ DB_CXX_NO_EXCEPTIONS DB_ENV_NO_OUTPUT_SET DB_ENV_RECOVER_FATAL
+ DB_EVENT_NOT_HANDLED DB_EVENT_REP_ELECTED DB_LOGFILEID_INVALID
+ DB_LOG_VERIFY_DBFILE DB_LOG_VERIFY_INTERR DB_PANIC_ENVIRONMENT
+ DB_PRIORITY_VERY_LOW DB_REP_CONF_AUTOINIT DB_REP_FULL_ELECTION
+ DB_REP_LEASE_EXPIRED DB_REP_LEASE_TIMEOUT DB_REP_WOULDROLLBACK
+ DB_STAT_LOCK_LOCKERS DB_STAT_LOCK_OBJECTS DB_STAT_MEMP_NOERROR
+ DB_TXN_BACKWARD_ROLL DB_TXN_LOCK_OPTIMIST */
+ /* Offset 15 gives the best switch position. */
+ switch (name[15]) {
+ case 'B':
+ if (memEQ(name, "DB_LOG_VERIFY_DBFILE", 20)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_DBFILE
+ *iv_return = DB_LOG_VERIFY_DBFILE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_BACKUP_READ_COUNT", 20)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \
+ DB_VERSION_PATCH >= 5)
+ *iv_return = DB_BACKUP_READ_COUNT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REP_FULL_ELECTION", 20)) {
+ /* ^ */
+#ifdef DB_REP_FULL_ELECTION
+ *iv_return = DB_REP_FULL_ELECTION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_LOCK_LOCKERS", 20)) {
+ /* ^ */
+#ifdef DB_STAT_LOCK_LOCKERS
+ *iv_return = DB_STAT_LOCK_LOCKERS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_BACKUP_SINGLE_DIR", 20)) {
+ /* ^ */
+#ifdef DB_BACKUP_SINGLE_DIR
+ *iv_return = DB_BACKUP_SINGLE_DIR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_EVENT_REP_ELECTED", 20)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_ELECTED
+ *iv_return = DB_EVENT_REP_ELECTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_STAT_MEMP_NOERROR", 20)) {
+ /* ^ */
+#ifdef DB_STAT_MEMP_NOERROR
+ *iv_return = DB_STAT_MEMP_NOERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "DB_ENV_RECOVER_FATAL", 20)) {
+ /* ^ */
+#ifdef DB_ENV_RECOVER_FATAL
+ *iv_return = DB_ENV_RECOVER_FATAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_TXN_LOCK_OPTIMIST", 20)) {
+ /* ^ */
+#ifdef DB_TXN_LOCK_OPTIMIST
+ *iv_return = DB_TXN_LOCK_OPTIMIST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'J':
+ if (memEQ(name, "DB_STAT_LOCK_OBJECTS", 20)) {
+ /* ^ */
+#ifdef DB_STAT_LOCK_OBJECTS
+ *iv_return = DB_STAT_LOCK_OBJECTS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_REP_WOULDROLLBACK", 20)) {
+ /* ^ */
+#ifdef DB_REP_WOULDROLLBACK
+ *iv_return = DB_REP_WOULDROLLBACK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_REP_LEASE_TIMEOUT", 20)) {
+ /* ^ */
+#ifdef DB_REP_LEASE_TIMEOUT
+ *iv_return = DB_REP_LEASE_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_EVENT_NOT_HANDLED", 20)) {
+ /* ^ */
+#ifdef DB_EVENT_NOT_HANDLED
+ *iv_return = DB_EVENT_NOT_HANDLED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_LOG_VERIFY_INTERR", 20)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_INTERR
+ *iv_return = DB_LOG_VERIFY_INTERR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PANIC_ENVIRONMENT", 20)) {
+ /* ^ */
+#ifdef DB_PANIC_ENVIRONMENT
+ *iv_return = DB_PANIC_ENVIRONMENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_REP_CONF_AUTOINIT", 20)) {
+ /* ^ */
+#ifdef DB_REP_CONF_AUTOINIT
+ *iv_return = DB_REP_CONF_AUTOINIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_REP_LEASE_EXPIRED", 20)) {
+ /* ^ */
+#ifdef DB_REP_LEASE_EXPIRED
+ *iv_return = DB_REP_LEASE_EXPIRED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_BACKUP_READ_SLEEP", 20)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \
+ DB_VERSION_PATCH >= 5)
+ *iv_return = DB_BACKUP_READ_SLEEP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_CXX_NO_EXCEPTIONS", 20)) {
+ /* ^ */
+#ifdef DB_CXX_NO_EXCEPTIONS
+ *iv_return = DB_CXX_NO_EXCEPTIONS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_ENV_NO_OUTPUT_SET", 20)) {
+ /* ^ */
+#ifdef DB_ENV_NO_OUTPUT_SET
+ *iv_return = DB_ENV_NO_OUTPUT_SET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'V':
+ if (memEQ(name, "DB_LOGFILEID_INVALID", 20)) {
+ /* ^ */
+#ifdef DB_LOGFILEID_INVALID
+ *iv_return = DB_LOGFILEID_INVALID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "DB_PRIORITY_VERY_LOW", 20)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_PRIORITY_VERY_LOW;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_TXN_BACKWARD_ROLL", 20)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 3) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_TXN_BACKWARD_ROLL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_21 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_ENV_LOG_AUTOREMOVE DB_EVENT_WRITE_FAILED DB_LOCK_UPGRADE_WRITE
+ DB_LOG_VERIFY_FORWARD DB_LOG_VERIFY_PARTIAL DB_LOG_VERIFY_VERBOSE
+ DB_LOG_VERIFY_WARNING DB_MUTEX_LOGICAL_LOCK DB_MUTEX_PROCESS_ONLY
+ DB_PRIORITY_UNCHANGED DB_PRIORITY_VERY_HIGH DB_REPMGR_ACKS_QUORUM
+ DB_REP_ELECTION_RETRY DB_REP_HEARTBEAT_SEND */
+ /* Offset 17 gives the best switch position. */
+ switch (name[17]) {
+ case 'B':
+ if (memEQ(name, "DB_LOG_VERIFY_VERBOSE", 21)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_VERBOSE
+ *iv_return = DB_LOG_VERIFY_VERBOSE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_REP_ELECTION_RETRY", 21)) {
+ /* ^ */
+#ifdef DB_REP_ELECTION_RETRY
+ *iv_return = DB_REP_ELECTION_RETRY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_PRIORITY_VERY_HIGH", 21)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \
+ DB_VERSION_PATCH >= 24)
+ *iv_return = DB_PRIORITY_VERY_HIGH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_EVENT_WRITE_FAILED", 21)) {
+ /* ^ */
+#ifdef DB_EVENT_WRITE_FAILED
+ *iv_return = DB_EVENT_WRITE_FAILED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_MUTEX_LOGICAL_LOCK", 21)) {
+ /* ^ */
+#ifdef DB_MUTEX_LOGICAL_LOCK
+ *iv_return = DB_MUTEX_LOGICAL_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "DB_ENV_LOG_AUTOREMOVE", 21)) {
+ /* ^ */
+#ifdef DB_ENV_LOG_AUTOREMOVE
+ *iv_return = DB_ENV_LOG_AUTOREMOVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_LOG_VERIFY_WARNING", 21)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_WARNING
+ *iv_return = DB_LOG_VERIFY_WARNING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_PRIORITY_UNCHANGED", 21)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 6) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 6 && \
+ DB_VERSION_PATCH >= 18)
+ *iv_return = DB_PRIORITY_UNCHANGED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_MUTEX_PROCESS_ONLY", 21)) {
+ /* ^ */
+#ifdef DB_MUTEX_PROCESS_ONLY
+ *iv_return = DB_MUTEX_PROCESS_ONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_ACKS_QUORUM", 21)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_QUORUM
+ *iv_return = DB_REPMGR_ACKS_QUORUM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_LOCK_UPGRADE_WRITE", 21)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 4) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \
+ (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \
+ DB_VERSION_PATCH >= 14)
+ *iv_return = DB_LOCK_UPGRADE_WRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_REP_HEARTBEAT_SEND", 21)) {
+ /* ^ */
+#ifdef DB_REP_HEARTBEAT_SEND
+ *iv_return = DB_REP_HEARTBEAT_SEND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_LOG_VERIFY_PARTIAL", 21)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_PARTIAL
+ *iv_return = DB_LOG_VERIFY_PARTIAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_LOG_VERIFY_FORWARD", 21)) {
+ /* ^ */
+#ifdef DB_LOG_VERIFY_FORWARD
+ *iv_return = DB_LOG_VERIFY_FORWARD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_22 (pTHX_ const char *name, IV *iv_return, const char **pv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_ASSOC_IMMUTABLE_KEY DB_BACKUP_WRITE_DIRECT DB_ENV_RPCCLIENT_GIVEN
+ DB_ENV_TIME_NOTGRANTED DB_ENV_TXN_NOT_DURABLE DB_EVENT_NO_SUCH_EVENT
+ DB_EVENT_REP_DUPMASTER DB_EVENT_REP_INIT_DONE DB_EVENT_REP_NEWMASTER
+ DB_LOGVERSION_LATCHING DB_REPMGR_DISCONNECTED DB_REP_CONF_NOAUTOINIT
+ DB_TXN_LOCK_OPTIMISTIC DB_VERSION_FULL_STRING */
+ /* Offset 15 gives the best switch position. */
+ switch (name[15]) {
+ case 'A':
+ if (memEQ(name, "DB_LOGVERSION_LATCHING", 22)) {
+ /* ^ */
+#ifdef DB_LOGVERSION_LATCHING
+ *iv_return = DB_LOGVERSION_LATCHING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "DB_ASSOC_IMMUTABLE_KEY", 22)) {
+ /* ^ */
+#ifdef DB_ASSOC_IMMUTABLE_KEY
+ *iv_return = DB_ASSOC_IMMUTABLE_KEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_ENV_TXN_NOT_DURABLE", 22)) {
+ /* ^ */
+#ifdef DB_ENV_TXN_NOT_DURABLE
+ *iv_return = DB_ENV_TXN_NOT_DURABLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_ENV_TIME_NOTGRANTED", 22)) {
+ /* ^ */
+#ifdef DB_ENV_TIME_NOTGRANTED
+ *iv_return = DB_ENV_TIME_NOTGRANTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "DB_EVENT_NO_SUCH_EVENT", 22)) {
+ /* ^ */
+#ifdef DB_EVENT_NO_SUCH_EVENT
+ *iv_return = DB_EVENT_NO_SUCH_EVENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_EVENT_REP_INIT_DONE", 22)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_INIT_DONE
+ *iv_return = DB_EVENT_REP_INIT_DONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_TXN_LOCK_OPTIMISTIC", 22)) {
+ /* ^ */
+#ifdef DB_TXN_LOCK_OPTIMISTIC
+ *iv_return = DB_TXN_LOCK_OPTIMISTIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_REPMGR_DISCONNECTED", 22)) {
+ /* ^ */
+#ifdef DB_REPMGR_DISCONNECTED
+ *iv_return = DB_REPMGR_DISCONNECTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_EVENT_REP_DUPMASTER", 22)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_DUPMASTER
+ *iv_return = DB_EVENT_REP_DUPMASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_ENV_RPCCLIENT_GIVEN", 22)) {
+ /* ^ */
+#ifdef DB_ENV_RPCCLIENT_GIVEN
+ *iv_return = DB_ENV_RPCCLIENT_GIVEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "DB_REP_CONF_NOAUTOINIT", 22)) {
+ /* ^ */
+#ifdef DB_REP_CONF_NOAUTOINIT
+ *iv_return = DB_REP_CONF_NOAUTOINIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "DB_EVENT_REP_NEWMASTER", 22)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_NEWMASTER
+ *iv_return = DB_EVENT_REP_NEWMASTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_BACKUP_WRITE_DIRECT", 22)) {
+ /* ^ */
+#if (DB_VERSION_MAJOR > 5) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \
+ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \
+ DB_VERSION_PATCH >= 5)
+ *iv_return = DB_BACKUP_WRITE_DIRECT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_VERSION_FULL_STRING", 22)) {
+ /* ^ */
+#ifdef DB_VERSION_FULL_STRING
+ *pv_return = DB_VERSION_FULL_STRING;
+ return PERL_constant_ISPV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_23 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_ENV_DATABASE_LOCKING DB_ENV_TXN_WRITE_NOSYNC DB_EVENT_REP_SITE_ADDED
+ DB_REPMGR_ACKS_ONE_PEER DB_REPMGR_NEED_RESPONSE DB_REP_CHECKPOINT_DELAY
+ DB_REP_CONF_DELAYCLIENT DB_REP_CONNECTION_RETRY DB_REP_DEFAULT_PRIORITY
+ DB_REP_ELECTION_TIMEOUT DB_VERB_REPMGR_CONNFAIL */
+ /* Offset 12 gives the best switch position. */
+ switch (name[12]) {
+ case 'A':
+ if (memEQ(name, "DB_ENV_DATABASE_LOCKING", 23)) {
+ /* ^ */
+#ifdef DB_ENV_DATABASE_LOCKING
+ *iv_return = DB_ENV_DATABASE_LOCKING;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_REP_CONNECTION_RETRY", 23)) {
+ /* ^ */
+#ifdef DB_REP_CONNECTION_RETRY
+ *iv_return = DB_REP_CONNECTION_RETRY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_REP_CONF_DELAYCLIENT", 23)) {
+ /* ^ */
+#ifdef DB_REP_CONF_DELAYCLIENT
+ *iv_return = DB_REP_CONF_DELAYCLIENT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_REPMGR_NEED_RESPONSE", 23)) {
+ /* ^ */
+#ifdef DB_REPMGR_NEED_RESPONSE
+ *iv_return = DB_REPMGR_NEED_RESPONSE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "DB_VERB_REPMGR_CONNFAIL", 23)) {
+ /* ^ */
+#ifdef DB_VERB_REPMGR_CONNFAIL
+ *iv_return = DB_VERB_REPMGR_CONNFAIL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "DB_REP_ELECTION_TIMEOUT", 23)) {
+ /* ^ */
+#ifdef DB_REP_ELECTION_TIMEOUT
+ *iv_return = DB_REP_ELECTION_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'K':
+ if (memEQ(name, "DB_REPMGR_ACKS_ONE_PEER", 23)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_ONE_PEER
+ *iv_return = DB_REPMGR_ACKS_ONE_PEER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_REP_DEFAULT_PRIORITY", 23)) {
+ /* ^ */
+#ifdef DB_REP_DEFAULT_PRIORITY
+ *iv_return = DB_REP_DEFAULT_PRIORITY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "DB_REP_CHECKPOINT_DELAY", 23)) {
+ /* ^ */
+#ifdef DB_REP_CHECKPOINT_DELAY
+ *iv_return = DB_REP_CHECKPOINT_DELAY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_ENV_TXN_WRITE_NOSYNC", 23)) {
+ /* ^ */
+#ifdef DB_ENV_TXN_WRITE_NOSYNC
+ *iv_return = DB_ENV_TXN_WRITE_NOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_EVENT_REP_SITE_ADDED", 23)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_SITE_ADDED
+ *iv_return = DB_EVENT_REP_SITE_ADDED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_24 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_EVENT_REP_PERM_FAILED DB_EVENT_REP_STARTUPDONE DB_HOTBACKUP_IN_PROGRESS
+ DB_INTERNAL_TEMPORARY_DB DB_REPMGR_ACKS_ALL_PEERS DB_REPMGR_CONF_ELECTIONS
+ DB_REP_CONF_AUTOROLLBACK DB_REP_HEARTBEAT_MONITOR */
+ /* Offset 22 gives the best switch position. */
+ switch (name[22]) {
+ case 'C':
+ if (memEQ(name, "DB_REP_CONF_AUTOROLLBACK", 24)) {
+ /* ^ */
+#ifdef DB_REP_CONF_AUTOROLLBACK
+ *iv_return = DB_REP_CONF_AUTOROLLBACK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "DB_INTERNAL_TEMPORARY_DB", 24)) {
+ /* ^ */
+#ifdef DB_INTERNAL_TEMPORARY_DB
+ *iv_return = DB_INTERNAL_TEMPORARY_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_EVENT_REP_PERM_FAILED", 24)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_PERM_FAILED
+ *iv_return = DB_EVENT_REP_PERM_FAILED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_EVENT_REP_STARTUPDONE", 24)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_STARTUPDONE
+ *iv_return = DB_EVENT_REP_STARTUPDONE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "DB_REPMGR_CONF_ELECTIONS", 24)) {
+ /* ^ */
+#ifdef DB_REPMGR_CONF_ELECTIONS
+ *iv_return = DB_REPMGR_CONF_ELECTIONS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "DB_REP_HEARTBEAT_MONITOR", 24)) {
+ /* ^ */
+#ifdef DB_REP_HEARTBEAT_MONITOR
+ *iv_return = DB_REP_HEARTBEAT_MONITOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "DB_REPMGR_ACKS_ALL_PEERS", 24)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_ALL_PEERS
+ *iv_return = DB_REPMGR_ACKS_ALL_PEERS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_HOTBACKUP_IN_PROGRESS", 24)) {
+ /* ^ */
+#ifdef DB_HOTBACKUP_IN_PROGRESS
+ *iv_return = DB_HOTBACKUP_IN_PROGRESS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_25 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_EVENT_REP_CONNECT_ESTD DB_EVENT_REP_JOIN_FAILURE
+ DB_EVENT_REP_SITE_REMOVED DB_INTERNAL_PERSISTENT_DB */
+ /* Offset 15 gives the best switch position. */
+ switch (name[15]) {
+ case 'I':
+ if (memEQ(name, "DB_EVENT_REP_JOIN_FAILURE", 25)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_JOIN_FAILURE
+ *iv_return = DB_EVENT_REP_JOIN_FAILURE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_EVENT_REP_CONNECT_ESTD", 25)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_CONNECT_ESTD
+ *iv_return = DB_EVENT_REP_CONNECT_ESTD;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_INTERNAL_PERSISTENT_DB", 25)) {
+ /* ^ */
+#ifdef DB_INTERNAL_PERSISTENT_DB
+ *iv_return = DB_INTERNAL_PERSISTENT_DB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_EVENT_REP_SITE_REMOVED", 25)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_SITE_REMOVED
+ *iv_return = DB_EVENT_REP_SITE_REMOVED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_27 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_EVENT_REP_CONNECT_BROKEN DB_EVENT_REP_MASTER_FAILURE
+ DB_EVENT_REP_WOULD_ROLLBACK DB_REPMGR_CONF_2SITE_STRICT */
+ /* Offset 16 gives the best switch position. */
+ switch (name[16]) {
+ case 'L':
+ if (memEQ(name, "DB_EVENT_REP_WOULD_ROLLBACK", 27)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_WOULD_ROLLBACK
+ *iv_return = DB_EVENT_REP_WOULD_ROLLBACK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "DB_EVENT_REP_CONNECT_BROKEN", 27)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_CONNECT_BROKEN
+ *iv_return = DB_EVENT_REP_CONNECT_BROKEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "DB_REPMGR_CONF_2SITE_STRICT", 27)) {
+ /* ^ */
+#ifdef DB_REPMGR_CONF_2SITE_STRICT
+ *iv_return = DB_REPMGR_CONF_2SITE_STRICT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_EVENT_REP_MASTER_FAILURE", 27)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_MASTER_FAILURE
+ *iv_return = DB_EVENT_REP_MASTER_FAILURE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_28 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_EVENT_REP_ELECTION_FAILED DB_REPMGR_ACKS_ALL_AVAILABLE
+ DB_REP_FULL_ELECTION_TIMEOUT */
+ /* Offset 15 gives the best switch position. */
+ switch (name[15]) {
+ case 'A':
+ if (memEQ(name, "DB_REPMGR_ACKS_ALL_AVAILABLE", 28)) {
+ /* ^ */
+#ifdef DB_REPMGR_ACKS_ALL_AVAILABLE
+ *iv_return = DB_REPMGR_ACKS_ALL_AVAILABLE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "DB_REP_FULL_ELECTION_TIMEOUT", 28)) {
+ /* ^ */
+#ifdef DB_REP_FULL_ELECTION_TIMEOUT
+ *iv_return = DB_REP_FULL_ELECTION_TIMEOUT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "DB_EVENT_REP_ELECTION_FAILED", 28)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_ELECTION_FAILED
+ *iv_return = DB_EVENT_REP_ELECTION_FAILED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/linux-shared/base/perl/install/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV PV)};
+my @names = (qw(DB2_AM_EXCL DB2_AM_INTEXCL DB2_AM_NOWAIT DB_AFTER DB_AGGRESSIVE
+ DB_ALREADY_ABORTED DB_APPEND DB_APPLY_LOGREG DB_APP_INIT
+ DB_ARCH_ABS DB_ARCH_DATA DB_ARCH_LOG DB_ARCH_REMOVE
+ DB_ASSOC_CREATE DB_ASSOC_IMMUTABLE_KEY DB_AUTO_COMMIT
+ DB_BACKUP_CLEAN DB_BACKUP_FILES DB_BACKUP_NO_LOGS
+ DB_BACKUP_SINGLE_DIR DB_BACKUP_UPDATE DB_BEFORE
+ DB_BOOTSTRAP_HELPER DB_BTREEMAGIC DB_BTREEOLDVER DB_BTREEVERSION
+ DB_BUFFER_SMALL DB_CACHED_COUNTS DB_CDB_ALLDB DB_CHECKPOINT
+ DB_CHKSUM DB_CHKSUM_SHA1 DB_CKP_INTERNAL DB_CLIENT DB_CL_WRITER
+ DB_COMMIT DB_COMPACT_FLAGS DB_CONSUME DB_CONSUME_WAIT DB_CREATE
+ DB_CURLSN DB_CURRENT DB_CURSOR_BULK DB_CURSOR_TRANSIENT
+ DB_CXX_NO_EXCEPTIONS DB_DATABASE_LOCK DB_DATABASE_LOCKING
+ DB_DEGREE_2 DB_DELETED DB_DELIMITER DB_DIRECT DB_DIRECT_DB
+ DB_DIRECT_LOG DB_DIRTY_READ DB_DONOTINDEX DB_DSYNC_DB
+ DB_DSYNC_LOG DB_DUP DB_DUPCURSOR DB_DUPSORT DB_DURABLE_UNKNOWN
+ DB_EID_BROADCAST DB_EID_INVALID DB_EID_MASTER DB_ENCRYPT
+ DB_ENCRYPT_AES DB_ENV_APPINIT DB_ENV_AUTO_COMMIT DB_ENV_CDB
+ DB_ENV_CDB_ALLDB DB_ENV_CREATE DB_ENV_DATABASE_LOCKING
+ DB_ENV_DBLOCAL DB_ENV_DIRECT_DB DB_ENV_DIRECT_LOG
+ DB_ENV_DSYNC_DB DB_ENV_DSYNC_LOG DB_ENV_FAILCHK DB_ENV_FATAL
+ DB_ENV_HOTBACKUP DB_ENV_LOCKDOWN DB_ENV_LOCKING DB_ENV_LOGGING
+ DB_ENV_LOG_AUTOREMOVE DB_ENV_LOG_INMEMORY DB_ENV_MULTIVERSION
+ DB_ENV_NOFLUSH DB_ENV_NOLOCKING DB_ENV_NOMMAP DB_ENV_NOPANIC
+ DB_ENV_NO_OUTPUT_SET DB_ENV_OPEN_CALLED DB_ENV_OVERWRITE
+ DB_ENV_PRIVATE DB_ENV_RECOVER_FATAL DB_ENV_REF_COUNTED
+ DB_ENV_REGION_INIT DB_ENV_REP_CLIENT DB_ENV_REP_LOGSONLY
+ DB_ENV_REP_MASTER DB_ENV_RPCCLIENT DB_ENV_RPCCLIENT_GIVEN
+ DB_ENV_STANDALONE DB_ENV_SYSTEM_MEM DB_ENV_THREAD
+ DB_ENV_TIME_NOTGRANTED DB_ENV_TXN DB_ENV_TXN_NOSYNC
+ DB_ENV_TXN_NOT_DURABLE DB_ENV_TXN_NOWAIT DB_ENV_TXN_SNAPSHOT
+ DB_ENV_TXN_WRITE_NOSYNC DB_ENV_USER_ALLOC DB_ENV_YIELDCPU
+ DB_EVENT_NOT_HANDLED DB_EVENT_NO_SUCH_EVENT DB_EVENT_PANIC
+ DB_EVENT_REG_ALIVE DB_EVENT_REG_PANIC DB_EVENT_REP_CLIENT
+ DB_EVENT_REP_CONNECT_BROKEN DB_EVENT_REP_CONNECT_ESTD
+ DB_EVENT_REP_CONNECT_TRY_FAILED DB_EVENT_REP_DUPMASTER
+ DB_EVENT_REP_ELECTED DB_EVENT_REP_ELECTION_FAILED
+ DB_EVENT_REP_INIT_DONE DB_EVENT_REP_JOIN_FAILURE
+ DB_EVENT_REP_LOCAL_SITE_REMOVED DB_EVENT_REP_MASTER
+ DB_EVENT_REP_MASTER_FAILURE DB_EVENT_REP_NEWMASTER
+ DB_EVENT_REP_PERM_FAILED DB_EVENT_REP_SITE_ADDED
+ DB_EVENT_REP_SITE_REMOVED DB_EVENT_REP_STARTUPDONE
+ DB_EVENT_REP_WOULD_ROLLBACK DB_EVENT_WRITE_FAILED DB_EXCL
+ DB_EXTENT DB_FAILCHK DB_FAILCHK_ISALIVE DB_FAST_STAT
+ DB_FCNTL_LOCKING DB_FILEOPEN DB_FILE_ID_LEN DB_FIRST DB_FIXEDLEN
+ DB_FLUSH DB_FORCE DB_FORCESYNC DB_FOREIGN_ABORT
+ DB_FOREIGN_CASCADE DB_FOREIGN_CONFLICT DB_FOREIGN_NULLIFY
+ DB_FREELIST_ONLY DB_FREE_SPACE DB_GETREC DB_GET_BOTH
+ DB_GET_BOTHC DB_GET_BOTH_LTE DB_GET_BOTH_RANGE DB_GET_RECNO
+ DB_GID_SIZE DB_GROUP_CREATOR DB_HANDLE_LOCK DB_HASHMAGIC
+ DB_HASHOLDVER DB_HASHVERSION DB_HEAPMAGIC DB_HEAPOLDVER
+ DB_HEAPVERSION DB_HEAP_FULL DB_HEAP_RID_SZ
+ DB_HOTBACKUP_IN_PROGRESS DB_IGNORE_LEASE DB_IMMUTABLE_KEY
+ DB_INCOMPLETE DB_INIT_CDB DB_INIT_LOCK DB_INIT_LOG DB_INIT_MPOOL
+ DB_INIT_MUTEX DB_INIT_REP DB_INIT_TXN DB_INORDER DB_INTERNAL_DB
+ DB_INTERNAL_PERSISTENT_DB DB_INTERNAL_TEMPORARY_DB
+ DB_JAVA_CALLBACK DB_JOINENV DB_JOIN_ITEM DB_JOIN_NOSORT
+ DB_KEYEMPTY DB_KEYEXIST DB_KEYFIRST DB_KEYLAST DB_LAST DB_LEGACY
+ DB_LOCAL_SITE DB_LOCKDOWN DB_LOCKMAGIC DB_LOCKVERSION
+ DB_LOCK_ABORT DB_LOCK_CHECK DB_LOCK_CONFLICT DB_LOCK_DEADLOCK
+ DB_LOCK_DEFAULT DB_LOCK_EXPIRE DB_LOCK_FREE_LOCKER
+ DB_LOCK_IGNORE_REC DB_LOCK_MAXLOCKS DB_LOCK_MAXWRITE
+ DB_LOCK_MINLOCKS DB_LOCK_MINWRITE DB_LOCK_NORUN DB_LOCK_NOTEXIST
+ DB_LOCK_NOTGRANTED DB_LOCK_NOTHELD DB_LOCK_NOWAIT DB_LOCK_OLDEST
+ DB_LOCK_RANDOM DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_RIW_N
+ DB_LOCK_RW_N DB_LOCK_SET_TIMEOUT DB_LOCK_SWITCH DB_LOCK_UPGRADE
+ DB_LOCK_YOUNGEST DB_LOGCHKSUM DB_LOGC_BUF_SIZE
+ DB_LOGFILEID_INVALID DB_LOGMAGIC DB_LOGOLDVER DB_LOGVERSION
+ DB_LOGVERSION_LATCHING DB_LOG_AUTOREMOVE DB_LOG_AUTO_REMOVE
+ DB_LOG_BUFFER_FULL DB_LOG_CHKPNT DB_LOG_COMMIT DB_LOG_DIRECT
+ DB_LOG_DISK DB_LOG_DSYNC DB_LOG_INMEMORY DB_LOG_IN_MEMORY
+ DB_LOG_LOCKED DB_LOG_NOCOPY DB_LOG_NOT_DURABLE DB_LOG_NO_DATA
+ DB_LOG_PERM DB_LOG_RESEND DB_LOG_SILENT_ERR DB_LOG_VERIFY_BAD
+ DB_LOG_VERIFY_CAF DB_LOG_VERIFY_DBFILE DB_LOG_VERIFY_ERR
+ DB_LOG_VERIFY_FORWARD DB_LOG_VERIFY_INTERR DB_LOG_VERIFY_PARTIAL
+ DB_LOG_VERIFY_VERBOSE DB_LOG_VERIFY_WARNING DB_LOG_WRNOSYNC
+ DB_LOG_ZERO DB_MAX_PAGES DB_MAX_RECORDS DB_MPOOL_CLEAN
+ DB_MPOOL_CREATE DB_MPOOL_DIRTY DB_MPOOL_DISCARD DB_MPOOL_EDIT
+ DB_MPOOL_EXTENT DB_MPOOL_FREE DB_MPOOL_LAST DB_MPOOL_NEW
+ DB_MPOOL_NEW_GROUP DB_MPOOL_NOFILE DB_MPOOL_NOLOCK
+ DB_MPOOL_PRIVATE DB_MPOOL_TRY DB_MPOOL_UNLINK DB_MULTIPLE
+ DB_MULTIPLE_KEY DB_MULTIVERSION DB_MUTEXDEBUG DB_MUTEXLOCKS
+ DB_MUTEX_ALLOCATED DB_MUTEX_LOCKED DB_MUTEX_LOGICAL_LOCK
+ DB_MUTEX_PROCESS_ONLY DB_MUTEX_SELF_BLOCK DB_MUTEX_SHARED
+ DB_MUTEX_THREAD DB_NEEDSPLIT DB_NEXT DB_NEXT_DUP DB_NEXT_NODUP
+ DB_NOCOPY DB_NODUPDATA DB_NOERROR DB_NOFLUSH DB_NOLOCKING
+ DB_NOMMAP DB_NOORDERCHK DB_NOOVERWRITE DB_NOPANIC DB_NORECURSE
+ DB_NOSERVER DB_NOSERVER_HOME DB_NOSERVER_ID DB_NOSYNC
+ DB_NOTFOUND DB_NO_AUTO_COMMIT DB_NO_CHECKPOINT DB_ODDFILESIZE
+ DB_OK_BTREE DB_OK_HASH DB_OK_HEAP DB_OK_QUEUE DB_OK_RECNO
+ DB_OLD_VERSION DB_OPEN_CALLED DB_OPFLAGS_MASK DB_ORDERCHKONLY
+ DB_OVERWRITE DB_OVERWRITE_DUP DB_PAD DB_PAGEYIELD DB_PAGE_LOCK
+ DB_PAGE_NOTFOUND DB_PANIC_ENVIRONMENT DB_PERMANENT DB_POSITION
+ DB_POSITIONI DB_PREV DB_PREV_DUP DB_PREV_NODUP DB_PRINTABLE
+ DB_PRIVATE DB_PR_HEADERS DB_PR_PAGE DB_PR_RECOVERYTEST
+ DB_QAMMAGIC DB_QAMOLDVER DB_QAMVERSION DB_RDONLY DB_RDWRMASTER
+ DB_READ_COMMITTED DB_READ_UNCOMMITTED DB_RECNUM DB_RECORDCOUNT
+ DB_RECORD_LOCK DB_RECOVER DB_RECOVER_FATAL DB_REGION_ANON
+ DB_REGION_INIT DB_REGION_MAGIC DB_REGION_NAME DB_REGISTER
+ DB_REGISTERED DB_RENAMEMAGIC DB_RENUMBER DB_REPFLAGS_MASK
+ DB_REPMGR_ACKS_ALL DB_REPMGR_ACKS_ALL_AVAILABLE
+ DB_REPMGR_ACKS_ALL_PEERS DB_REPMGR_ACKS_NONE DB_REPMGR_ACKS_ONE
+ DB_REPMGR_ACKS_ONE_PEER DB_REPMGR_ACKS_QUORUM
+ DB_REPMGR_CONF_2SITE_STRICT DB_REPMGR_CONF_ELECTIONS
+ DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISPEER
+ DB_REPMGR_NEED_RESPONSE DB_REPMGR_PEER DB_REP_ACK_TIMEOUT
+ DB_REP_ANYWHERE DB_REP_BULKOVF DB_REP_CHECKPOINT_DELAY
+ DB_REP_CLIENT DB_REP_CONF_AUTOINIT DB_REP_CONF_AUTOROLLBACK
+ DB_REP_CONF_BULK DB_REP_CONF_DELAYCLIENT DB_REP_CONF_INMEM
+ DB_REP_CONF_LEASE DB_REP_CONF_NOAUTOINIT DB_REP_CONF_NOWAIT
+ DB_REP_CONNECTION_RETRY DB_REP_CREATE DB_REP_DEFAULT_PRIORITY
+ DB_REP_DUPMASTER DB_REP_EGENCHG DB_REP_ELECTION
+ DB_REP_ELECTION_RETRY DB_REP_ELECTION_TIMEOUT
+ DB_REP_FULL_ELECTION DB_REP_FULL_ELECTION_TIMEOUT
+ DB_REP_HANDLE_DEAD DB_REP_HEARTBEAT_MONITOR
+ DB_REP_HEARTBEAT_SEND DB_REP_HOLDELECTION DB_REP_IGNORE
+ DB_REP_ISPERM DB_REP_JOIN_FAILURE DB_REP_LEASE_EXPIRED
+ DB_REP_LEASE_TIMEOUT DB_REP_LOCKOUT DB_REP_LOGREADY
+ DB_REP_LOGSONLY DB_REP_MASTER DB_REP_NEWMASTER DB_REP_NEWSITE
+ DB_REP_NOBUFFER DB_REP_NOTPERM DB_REP_OUTDATED DB_REP_PAGEDONE
+ DB_REP_PAGELOCKED DB_REP_PERMANENT DB_REP_REREQUEST
+ DB_REP_STARTUPDONE DB_REP_UNAVAIL DB_REP_WOULDROLLBACK
+ DB_REVSPLITOFF DB_RMW DB_RPCCLIENT DB_RPC_SERVERPROG
+ DB_RPC_SERVERVERS DB_RUNRECOVERY DB_SALVAGE DB_SA_SKIPFIRSTKEY
+ DB_SA_UNKNOWNKEY DB_SECONDARY_BAD DB_SEQUENCE_OLDVER
+ DB_SEQUENCE_VERSION DB_SEQUENTIAL DB_SEQ_DEC DB_SEQ_INC
+ DB_SEQ_RANGE_SET DB_SEQ_WRAP DB_SEQ_WRAPPED DB_SET
+ DB_SET_LOCK_TIMEOUT DB_SET_LTE DB_SET_RANGE DB_SET_RECNO
+ DB_SET_REG_TIMEOUT DB_SET_TXN_NOW DB_SET_TXN_TIMEOUT
+ DB_SHALLOW_DUP DB_SNAPSHOT DB_SPARE_FLAG DB_STAT_ALL
+ DB_STAT_ALLOC DB_STAT_CLEAR DB_STAT_LOCK_CONF
+ DB_STAT_LOCK_LOCKERS DB_STAT_LOCK_OBJECTS DB_STAT_LOCK_PARAMS
+ DB_STAT_MEMP_HASH DB_STAT_MEMP_NOERROR DB_STAT_NOERROR
+ DB_STAT_SUBSYSTEM DB_STAT_SUMMARY DB_ST_DUPOK DB_ST_DUPSET
+ DB_ST_DUPSORT DB_ST_IS_RECNO DB_ST_OVFL_LEAF DB_ST_RECNUM
+ DB_ST_RELEN DB_ST_TOPLEVEL DB_SURPRISE_KID DB_SWAPBYTES
+ DB_SYSTEM_MEM DB_TEMPORARY DB_TEST_ELECTINIT DB_TEST_ELECTSEND
+ DB_TEST_ELECTVOTE1 DB_TEST_ELECTVOTE2 DB_TEST_ELECTWAIT1
+ DB_TEST_ELECTWAIT2 DB_TEST_POSTDESTROY DB_TEST_POSTLOG
+ DB_TEST_POSTLOGMETA DB_TEST_POSTOPEN DB_TEST_POSTRENAME
+ DB_TEST_POSTSYNC DB_TEST_PREDESTROY DB_TEST_PREOPEN
+ DB_TEST_PRERENAME DB_TEST_RECYCLE DB_TEST_SUBDB_LOCKS DB_THREAD
+ DB_THREADID_STRLEN DB_TIMEOUT DB_TIME_NOTGRANTED DB_TRUNCATE
+ DB_TXNMAGIC DB_TXNVERSION DB_TXN_BULK DB_TXN_CKP DB_TXN_FAMILY
+ DB_TXN_LOCK DB_TXN_LOCK_2PL DB_TXN_LOCK_MASK
+ DB_TXN_LOCK_OPTIMIST DB_TXN_LOCK_OPTIMISTIC DB_TXN_LOG_MASK
+ DB_TXN_LOG_REDO DB_TXN_LOG_UNDO DB_TXN_LOG_UNDOREDO
+ DB_TXN_NOSYNC DB_TXN_NOT_DURABLE DB_TXN_NOWAIT DB_TXN_REDO
+ DB_TXN_SNAPSHOT DB_TXN_SYNC DB_TXN_TOKEN_SIZE DB_TXN_UNDO
+ DB_TXN_WAIT DB_TXN_WRITE_NOSYNC DB_UNREF DB_UPDATE_SECONDARY
+ DB_UPGRADE DB_USERCOPY_GETDATA DB_USERCOPY_SETDATA
+ DB_USE_ENVIRON DB_USE_ENVIRON_ROOT DB_VERB_BACKUP
+ DB_VERB_CHKPOINT DB_VERB_DEADLOCK DB_VERB_FILEOPS
+ DB_VERB_FILEOPS_ALL DB_VERB_RECOVERY DB_VERB_REGISTER
+ DB_VERB_REPLICATION DB_VERB_REPMGR_CONNFAIL DB_VERB_REPMGR_MISC
+ DB_VERB_REP_ELECT DB_VERB_REP_LEASE DB_VERB_REP_MISC
+ DB_VERB_REP_MSGS DB_VERB_REP_SYNC DB_VERB_REP_SYSTEM
+ DB_VERB_REP_TEST DB_VERB_WAITSFOR DB_VERIFY DB_VERIFY_BAD
+ DB_VERIFY_FATAL DB_VERIFY_PARTITION DB_VERSION_FAMILY
+ DB_VERSION_MAJOR DB_VERSION_MINOR DB_VERSION_MISMATCH
+ DB_VERSION_PATCH DB_VERSION_RELEASE DB_VRFY_FLAGMASK
+ DB_WRITECURSOR DB_WRITELOCK DB_WRITEOPEN DB_WRNOSYNC
+ DB_XA_CREATE DB_XIDDATASIZE DB_YIELDCPU DB_debug_FLAG
+ DB_user_BEGIN),
+ {name=>"DB_BACKUP_READ_COUNT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 5)\n", "#endif\n"]},
+ {name=>"DB_BACKUP_READ_SLEEP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 5)\n", "#endif\n"]},
+ {name=>"DB_BACKUP_SIZE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 5)\n", "#endif\n"]},
+ {name=>"DB_BACKUP_WRITE_DIRECT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 5)\n", "#endif\n"]},
+ {name=>"DB_BTREE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_HASH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_HEAP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_LOCK_DUMP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_LOCK_GET", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_LOCK_GET_TIMEOUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_LOCK_INHERIT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 7) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 7 && \\\n DB_VERSION_PATCH >= 1)\n", "#endif\n"]},
+ {name=>"DB_LOCK_PUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_LOCK_PUT_ALL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_LOCK_PUT_OBJ", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_LOCK_PUT_READ", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_LOCK_TIMEOUT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_LOCK_TRADE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_LOCK_UPGRADE_WRITE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_LOCK", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_LOCKER", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_LOCKOBJECT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_LOGID", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_THREAD", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_MEM_TRANSACTION", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 2) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 2 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_DEFAULT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_HIGH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_LOW", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_UNCHANGED", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 6) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 6 && \\\n DB_VERSION_PATCH >= 18)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_VERY_HIGH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_PRIORITY_VERY_LOW", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_QUEUE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 55)\n", "#endif\n"]},
+ {name=>"DB_RECNO", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_TXN_ABORT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_APPLY", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_BACKWARD_ROLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_FORWARD_ROLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_LOG_VERIFY", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"DB_TXN_OPENFILES", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 3) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_POPENFILES", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 14)\n", "#endif\n"]},
+ {name=>"DB_TXN_PRINT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 4) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR > 1) || \\\n (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 1 && \\\n DB_VERSION_PATCH >= 24)\n", "#endif\n"]},
+ {name=>"DB_UNKNOWN", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 2) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 3)\n", "#endif\n"]},
+ {name=>"DB_VERSION_FULL_STRING", type=>"PV"},
+ {name=>"DB_VERSION_STRING", type=>"PV"},
+ {name=>"LOGREC_ARG", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_DATA", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_DB", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_DBOP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_DBT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_Done", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_HDR", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_LOCKS", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_OP", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_PGDBT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_PGDDBT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_PGLIST", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_POINTER", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]},
+ {name=>"LOGREC_TIME", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 5) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 6)\n", "#endif\n"]});
+
+print constant_types(), "\n"; # macro defs
+foreach (C_constant ("BerkeleyDB", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "\n#### XS Section:\n";
+print XS_constant ("BerkeleyDB", $types);
+__END__
+ */
+
+ switch (len) {
+ case 6:
+ return constant_6 (aTHX_ name, iv_return);
+ break;
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ return constant_8 (aTHX_ name, iv_return);
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return);
+ break;
+ case 10:
+ return constant_10 (aTHX_ name, iv_return);
+ break;
+ case 11:
+ return constant_11 (aTHX_ name, iv_return);
+ break;
+ case 12:
+ return constant_12 (aTHX_ name, iv_return);
+ break;
+ case 13:
+ return constant_13 (aTHX_ name, iv_return);
+ break;
+ case 14:
+ return constant_14 (aTHX_ name, iv_return);
+ break;
+ case 15:
+ return constant_15 (aTHX_ name, iv_return);
+ break;
+ case 16:
+ return constant_16 (aTHX_ name, iv_return);
+ break;
+ case 17:
+ return constant_17 (aTHX_ name, iv_return, pv_return);
+ break;
+ case 18:
+ return constant_18 (aTHX_ name, iv_return);
+ break;
+ case 19:
+ return constant_19 (aTHX_ name, iv_return);
+ break;
+ case 20:
+ return constant_20 (aTHX_ name, iv_return);
+ break;
+ case 21:
+ return constant_21 (aTHX_ name, iv_return);
+ break;
+ case 22:
+ return constant_22 (aTHX_ name, iv_return, pv_return);
+ break;
+ case 23:
+ return constant_23 (aTHX_ name, iv_return);
+ break;
+ case 24:
+ return constant_24 (aTHX_ name, iv_return);
+ break;
+ case 25:
+ return constant_25 (aTHX_ name, iv_return);
+ break;
+ case 27:
+ return constant_27 (aTHX_ name, iv_return);
+ break;
+ case 28:
+ return constant_28 (aTHX_ name, iv_return);
+ break;
+ case 31:
+ /* Names all of length 31. */
+ /* DB_EVENT_REP_CONNECT_TRY_FAILED DB_EVENT_REP_LOCAL_SITE_REMOVED */
+ /* Offset 19 gives the best switch position. */
+ switch (name[19]) {
+ case 'S':
+ if (memEQ(name, "DB_EVENT_REP_LOCAL_SITE_REMOVED", 31)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_LOCAL_SITE_REMOVED
+ *iv_return = DB_EVENT_REP_LOCAL_SITE_REMOVED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "DB_EVENT_REP_CONNECT_TRY_FAILED", 31)) {
+ /* ^ */
+#ifdef DB_EVENT_REP_CONNECT_TRY_FAILED
+ *iv_return = DB_EVENT_REP_CONNECT_TRY_FAILED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
diff --git a/lang/perl/BerkeleyDB/constants.xs b/lang/perl/BerkeleyDB/constants.xs
new file mode 100644
index 00000000..125d94c0
--- /dev/null
+++ b/lang/perl/BerkeleyDB/constants.xs
@@ -0,0 +1,89 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ const char *pv;
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv, &pv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv =
+ sv_2mortal(newSVpvf("%s is not a valid BerkeleyDB macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined BerkeleyDB macro %s, used",
+ s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break;
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing BerkeleyDB macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
diff --git a/lang/perl/BerkeleyDB/dbinfo b/lang/perl/BerkeleyDB/dbinfo
new file mode 100755
index 00000000..4e88697d
--- /dev/null
+++ b/lang/perl/BerkeleyDB/dbinfo
@@ -0,0 +1,141 @@
+#!/usr/local/bin/perl
+
+# Name: dbinfo -- identify berkeley DB version used to create
+# a database file
+#
+# Author: Paul Marquess <Paul.Marquess@btinternet.com>
+# Version: 1.07
+# Date 2nd April 2011
+#
+# Copyright (c) 1998-2011 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 => # DB_BTREEMAGIC
+ {
+ Type => "Btree",
+ Versions => # DB_BTREEVERSION
+ {
+ 1 => [0, "Unknown (older than 1.71)"],
+ 2 => [0, "Unknown (older than 1.71)"],
+ 3 => [0, "1.71 -> 1.85, 1.86"],
+ 4 => [0, "Unknown"],
+ 5 => [0, "2.0.0 -> 2.3.0"],
+ 6 => [0, "2.3.1 -> 2.7.7"],
+ 7 => [0, "3.0.x"],
+ 8 => [0, "3.1.x -> 4.0.x"],
+ 9 => [1, "4.1.x or greater"],
+ }
+ },
+ 0x061561 => # DB_HASHMAGIC
+ {
+ Type => "Hash",
+ Versions => # DB_HASHVERSION
+ {
+ 1 => [0, "Unknown (older than 1.71)"],
+ 2 => [0, "1.71 -> 1.85"],
+ 3 => [0, "1.86"],
+ 4 => [0, "2.0.0 -> 2.1.0"],
+ 5 => [0, "2.2.6 -> 2.7.7"],
+ 6 => [0, "3.0.x"],
+ 7 => [0, "3.1.x -> 4.0.x"],
+ 8 => [1, "4.1.x or greater"],
+ 9 => [1, "4.6.x or greater"],
+ }
+ },
+ 0x042253 => # DB_QAMMAGIC
+ {
+ Type => "Queue",
+ Versions => # DB_QAMVERSION
+ {
+ 1 => [0, "3.0.x"],
+ 2 => [0, "3.1.x"],
+ 3 => [0, "3.2.x -> 4.0.x"],
+ 4 => [1, "4.1.x or greater"],
+ }
+ },
+ 0x074582 => # DB_HEAPMAGIC
+ {
+ Type => "Heap",
+ Versions => # DB_HEAPVERSION
+ {
+ 1 => [1, "5.2.x"],
+ }
+ },
+ ) ;
+
+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, 30 ;
+
+
+my (@info) = unpack("NNNNNNC", $buff) ;
+my (@info1) = unpack("VVVVVVC", $buff) ;
+my ($magic, $version, $endian, $encrypt) ;
+
+if ($Data{$info[0]}) # first try DB 1.x format, big endian
+{
+ $magic = $info[0] ;
+ $version = $info[1] ;
+ $endian = "Big Endian" ;
+ $encrypt = "Not Supported";
+}
+elsif ($Data{$info1[0]}) # first try DB 1.x format, little endian
+{
+ $magic = $info1[0] ;
+ $version = $info1[1] ;
+ $endian = "Little Endian" ;
+ $encrypt = "Not Supported";
+}
+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} ;
+$magic = sprintf "%06X", $magic ;
+
+my $ver_string = "Unknown" ;
+
+if ( defined $type->{Versions}{$version} )
+{
+ $ver_string = $type->{Versions}{$version}[1];
+ if ($type->{Versions}{$version}[0] )
+ { $encrypt = $info[6] ? "Enabled" : "Disabled" }
+ else
+ { $encrypt = "Not Supported" }
+}
+
+print <<EOM ;
+File Type: Berkeley DB $type->{Type} file.
+File Version ID: $version
+Built with Berkeley DB: $ver_string
+Byte Order: $endian
+Magic: $magic
+Encryption: $encrypt
+EOM
+
+close F ;
+
+exit ;
diff --git a/lang/perl/BerkeleyDB/hints/dec_osf.pl b/lang/perl/BerkeleyDB/hints/dec_osf.pl
new file mode 100644
index 00000000..6d7faeed
--- /dev/null
+++ b/lang/perl/BerkeleyDB/hints/dec_osf.pl
@@ -0,0 +1 @@
+$self->{LIBS} = [ "@{$self->{LIBS}} -lpthreads" ];
diff --git a/lang/perl/BerkeleyDB/hints/irix_6_5.pl b/lang/perl/BerkeleyDB/hints/irix_6_5.pl
new file mode 100644
index 00000000..b531673e
--- /dev/null
+++ b/lang/perl/BerkeleyDB/hints/irix_6_5.pl
@@ -0,0 +1 @@
+$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ];
diff --git a/lang/perl/BerkeleyDB/hints/solaris.pl b/lang/perl/BerkeleyDB/hints/solaris.pl
new file mode 100644
index 00000000..ddd941d6
--- /dev/null
+++ b/lang/perl/BerkeleyDB/hints/solaris.pl
@@ -0,0 +1 @@
+$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ];
diff --git a/lang/perl/BerkeleyDB/mkconsts.pl b/lang/perl/BerkeleyDB/mkconsts.pl
new file mode 100644
index 00000000..8d3c5087
--- /dev/null
+++ b/lang/perl/BerkeleyDB/mkconsts.pl
@@ -0,0 +1,1149 @@
+#!/usr/bin/perl
+
+use ExtUtils::Constant qw(WriteConstants);
+
+use constant DEFINE => 'define' ;
+use constant STRING => 'string' ;
+use constant IGNORE => 'ignore' ;
+
+%constants = (
+
+ #########
+ # 2.0.3
+ #########
+
+ DBM_INSERT => IGNORE,
+ DBM_REPLACE => IGNORE,
+ DBM_SUFFIX => IGNORE,
+ DB_AFTER => DEFINE,
+ DB_AM_DUP => IGNORE,
+ DB_AM_INMEM => IGNORE,
+ DB_AM_LOCKING => IGNORE,
+ DB_AM_LOGGING => IGNORE,
+ DB_AM_MLOCAL => IGNORE,
+ DB_AM_PGDEF => IGNORE,
+ DB_AM_RDONLY => IGNORE,
+ DB_AM_RECOVER => IGNORE,
+ DB_AM_SWAP => IGNORE,
+ DB_AM_TXN => IGNORE,
+ DB_APP_INIT => DEFINE,
+ DB_BEFORE => DEFINE,
+ DB_BTREEMAGIC => DEFINE,
+ DB_BTREEVERSION => DEFINE,
+ DB_BT_DELIMITER => IGNORE,
+ DB_BT_EOF => IGNORE,
+ DB_BT_FIXEDLEN => IGNORE,
+ DB_BT_PAD => IGNORE,
+ DB_BT_SNAPSHOT => IGNORE,
+ DB_CHECKPOINT => DEFINE,
+ DB_CREATE => DEFINE,
+ DB_CURRENT => DEFINE,
+ DB_DBT_INTERNAL => IGNORE,
+ DB_DBT_MALLOC => IGNORE,
+ DB_DBT_PARTIAL => IGNORE,
+ DB_DBT_USERMEM => IGNORE,
+ DB_DELETED => DEFINE,
+ DB_DELIMITER => DEFINE,
+ DB_DUP => DEFINE,
+ DB_EXCL => DEFINE,
+ DB_FIRST => DEFINE,
+ DB_FIXEDLEN => DEFINE,
+ DB_FLUSH => DEFINE,
+ DB_HASHMAGIC => DEFINE,
+ DB_HASHVERSION => DEFINE,
+ DB_HS_DIRTYMETA => IGNORE,
+ DB_INCOMPLETE => DEFINE,
+ DB_INIT_LOCK => DEFINE,
+ DB_INIT_LOG => DEFINE,
+ DB_INIT_MPOOL => DEFINE,
+ DB_INIT_TXN => DEFINE,
+ DB_KEYEXIST => DEFINE,
+ DB_KEYFIRST => DEFINE,
+ DB_KEYLAST => DEFINE,
+ DB_LAST => DEFINE,
+ DB_LOCKMAGIC => DEFINE,
+ DB_LOCKVERSION => DEFINE,
+ DB_LOCK_DEADLOCK => DEFINE,
+ DB_LOCK_NOTGRANTED => DEFINE,
+ DB_LOCK_NOTHELD => DEFINE,
+ DB_LOCK_NOWAIT => DEFINE,
+ DB_LOCK_RIW_N => DEFINE,
+ DB_LOCK_RW_N => DEFINE,
+ DB_LOGMAGIC => DEFINE,
+ DB_LOGVERSION => DEFINE,
+ DB_MAX_PAGES => DEFINE,
+ DB_MAX_RECORDS => DEFINE,
+ DB_MPOOL_CLEAN => DEFINE,
+ DB_MPOOL_CREATE => DEFINE,
+ DB_MPOOL_DIRTY => DEFINE,
+ DB_MPOOL_DISCARD => DEFINE,
+ DB_MPOOL_LAST => DEFINE,
+ DB_MPOOL_NEW => DEFINE,
+ DB_MPOOL_PRIVATE => DEFINE,
+ DB_MUTEXDEBUG => DEFINE,
+ DB_NEEDSPLIT => DEFINE,
+ DB_NEXT => DEFINE,
+ DB_NOOVERWRITE => DEFINE,
+ DB_NORECURSE => DEFINE,
+ DB_NOSYNC => DEFINE,
+ DB_NOTFOUND => DEFINE,
+ DB_PAD => DEFINE,
+ DB_PREV => DEFINE,
+ DB_RDONLY => DEFINE,
+ DB_REGISTERED => DEFINE,
+ DB_RE_MODIFIED => IGNORE,
+ DB_SEQUENTIAL => DEFINE,
+ DB_SET => DEFINE,
+ DB_SET_RANGE => DEFINE,
+ DB_SNAPSHOT => DEFINE,
+ DB_SWAPBYTES => DEFINE,
+ DB_TEMPORARY => DEFINE,
+ DB_TRUNCATE => DEFINE,
+ DB_TXNMAGIC => DEFINE,
+ DB_TXNVERSION => DEFINE,
+ DB_TXN_BACKWARD_ROLL => DEFINE,
+ DB_TXN_FORWARD_ROLL => DEFINE,
+ DB_TXN_LOCK_2PL => DEFINE,
+ DB_TXN_LOCK_MASK => DEFINE,
+ DB_TXN_LOCK_OPTIMISTIC => DEFINE,
+ DB_TXN_LOG_MASK => DEFINE,
+ DB_TXN_LOG_REDO => DEFINE,
+ DB_TXN_LOG_UNDO => DEFINE,
+ DB_TXN_LOG_UNDOREDO => DEFINE,
+ DB_TXN_OPENFILES => DEFINE,
+ DB_TXN_REDO => DEFINE,
+ DB_TXN_UNDO => DEFINE,
+ DB_USE_ENVIRON => DEFINE,
+ DB_USE_ENVIRON_ROOT => DEFINE,
+ DB_VERSION_MAJOR => DEFINE,
+ DB_VERSION_MINOR => DEFINE,
+ DB_VERSION_PATCH => DEFINE,
+ DB_VERSION_STRING => STRING,
+ _DB_H_ => IGNORE,
+ __BIT_TYPES_DEFINED__ => IGNORE,
+ const => IGNORE,
+
+ # enum DBTYPE
+ DB_BTREE => '2.0.3',
+ DB_HASH => '2.0.3',
+ DB_RECNO => '2.0.3',
+ DB_UNKNOWN => '2.0.3',
+
+ # enum db_lockop_t
+ DB_LOCK_DUMP => '2.0.3',
+ DB_LOCK_GET => '2.0.3',
+ DB_LOCK_PUT => '2.0.3',
+ DB_LOCK_PUT_ALL => '2.0.3',
+ DB_LOCK_PUT_OBJ => '2.0.3',
+
+ # enum db_lockmode_t
+ DB_LOCK_NG => IGNORE, # 2.0.3
+ DB_LOCK_READ => IGNORE, # 2.0.3
+ DB_LOCK_WRITE => IGNORE, # 2.0.3
+ DB_LOCK_IREAD => IGNORE, # 2.0.3
+ DB_LOCK_IWRITE => IGNORE, # 2.0.3
+ DB_LOCK_IWR => IGNORE, # 2.0.3
+
+ # enum ACTION
+ FIND => IGNORE, # 2.0.3
+ ENTER => IGNORE, # 2.0.3
+
+ #########
+ # 2.1.0
+ #########
+
+ DB_NOMMAP => DEFINE,
+
+ #########
+ # 2.2.6
+ #########
+
+ DB_AM_THREAD => IGNORE,
+ DB_ARCH_ABS => DEFINE,
+ DB_ARCH_DATA => DEFINE,
+ DB_ARCH_LOG => DEFINE,
+ DB_LOCK_CONFLICT => DEFINE,
+ DB_LOCK_DEFAULT => DEFINE,
+ DB_LOCK_NORUN => DEFINE,
+ DB_LOCK_OLDEST => DEFINE,
+ DB_LOCK_RANDOM => DEFINE,
+ DB_LOCK_YOUNGEST => DEFINE,
+ DB_RECOVER => DEFINE,
+ DB_RECOVER_FATAL => DEFINE,
+ DB_THREAD => DEFINE,
+ DB_TXN_NOSYNC => DEFINE,
+
+ #########
+ # 2.3.0
+ #########
+
+ DB_BTREEOLDVER => DEFINE,
+ DB_BT_RECNUM => IGNORE,
+ DB_FILE_ID_LEN => DEFINE,
+ DB_GETREC => DEFINE,
+ DB_HASHOLDVER => DEFINE,
+ DB_KEYEMPTY => DEFINE,
+ DB_LOGOLDVER => DEFINE,
+ DB_RECNUM => DEFINE,
+ DB_RECORDCOUNT => DEFINE,
+ DB_RENUMBER => DEFINE,
+ DB_RE_DELIMITER => IGNORE,
+ DB_RE_FIXEDLEN => IGNORE,
+ DB_RE_PAD => IGNORE,
+ DB_RE_RENUMBER => IGNORE,
+ DB_RE_SNAPSHOT => IGNORE,
+
+ #########
+ # 2.3.10
+ #########
+
+ DB_APPEND => DEFINE,
+ DB_GET_RECNO => DEFINE,
+ DB_SET_RECNO => DEFINE,
+ DB_TXN_CKP => DEFINE,
+
+ #########
+ # 2.3.11
+ #########
+
+ DB_ENV_APPINIT => DEFINE,
+ DB_ENV_STANDALONE => DEFINE,
+ DB_ENV_THREAD => DEFINE,
+
+ #########
+ # 2.3.12
+ #########
+
+ DB_FUNC_CALLOC => IGNORE,
+ DB_FUNC_CLOSE => IGNORE,
+ DB_FUNC_DIRFREE => IGNORE,
+ DB_FUNC_DIRLIST => IGNORE,
+ DB_FUNC_EXISTS => IGNORE,
+ DB_FUNC_FREE => IGNORE,
+ DB_FUNC_FSYNC => IGNORE,
+ DB_FUNC_IOINFO => IGNORE,
+ DB_FUNC_MALLOC => IGNORE,
+ DB_FUNC_MAP => IGNORE,
+ DB_FUNC_OPEN => IGNORE,
+ DB_FUNC_READ => IGNORE,
+ DB_FUNC_REALLOC => IGNORE,
+ DB_FUNC_SEEK => IGNORE,
+ DB_FUNC_SLEEP => IGNORE,
+ DB_FUNC_STRDUP => IGNORE,
+ DB_FUNC_UNLINK => IGNORE,
+ DB_FUNC_UNMAP => IGNORE,
+ DB_FUNC_WRITE => IGNORE,
+ DB_FUNC_YIELD => IGNORE,
+
+ #########
+ # 2.3.14
+ #########
+
+ DB_TSL_SPINS => IGNORE,
+
+ #########
+ # 2.3.16
+ #########
+
+ DB_DBM_HSEARCH => IGNORE,
+ firstkey => IGNORE,
+ hdestroy => IGNORE,
+
+ #########
+ # 2.4.10
+ #########
+
+ DB_CURLSN => DEFINE,
+ DB_FUNC_RUNLINK => IGNORE,
+ DB_REGION_ANON => DEFINE,
+ DB_REGION_INIT => DEFINE,
+ DB_REGION_NAME => DEFINE,
+ DB_TXN_LOCK_OPTIMIST => DEFINE,
+ __CURRENTLY_UNUSED => IGNORE,
+
+ # enum db_status_t
+ DB_LSTAT_ABORTED => IGNORE, # 2.4.10
+ DB_LSTAT_ERR => IGNORE, # 2.4.10
+ DB_LSTAT_FREE => IGNORE, # 2.4.10
+ DB_LSTAT_HELD => IGNORE, # 2.4.10
+ DB_LSTAT_NOGRANT => IGNORE, # 2.4.10
+ DB_LSTAT_PENDING => IGNORE, # 2.4.10
+ DB_LSTAT_WAITING => IGNORE, # 2.4.10
+
+ #########
+ # 2.4.14
+ #########
+
+ DB_MUTEXLOCKS => DEFINE,
+ DB_PAGEYIELD => DEFINE,
+ __UNUSED_100 => IGNORE,
+ __UNUSED_4000 => IGNORE,
+
+ #########
+ # 2.5.9
+ #########
+
+ DBC_CONTINUE => IGNORE,
+ DBC_KEYSET => IGNORE,
+ DBC_RECOVER => IGNORE,
+ DBC_RMW => IGNORE,
+ DB_DBM_ERROR => IGNORE,
+ DB_DUPSORT => DEFINE,
+ DB_GET_BOTH => DEFINE,
+ DB_JOIN_ITEM => DEFINE,
+ DB_NEXT_DUP => DEFINE,
+ DB_OPFLAGS_MASK => DEFINE,
+ DB_RMW => DEFINE,
+ DB_RUNRECOVERY => DEFINE,
+ dbmclose => IGNORE,
+
+ #########
+ # 2.6.4
+ #########
+
+ DBC_WRITER => IGNORE,
+ DB_AM_CDB => IGNORE,
+ DB_ENV_CDB => DEFINE,
+ DB_INIT_CDB => DEFINE,
+ DB_LOCK_UPGRADE => DEFINE,
+ DB_WRITELOCK => DEFINE,
+
+ #########
+ # 2.7.1
+ #########
+
+
+ # enum db_lockop_t
+ DB_LOCK_INHERIT => '2.7.1',
+
+ #########
+ # 2.7.7
+ #########
+
+ DB_FCNTL_LOCKING => DEFINE,
+
+ #########
+ # 3.0.55
+ #########
+
+ DBC_WRITECURSOR => IGNORE,
+ DB_AM_DISCARD => IGNORE,
+ DB_AM_SUBDB => IGNORE,
+ DB_BT_REVSPLIT => IGNORE,
+ DB_CONSUME => DEFINE,
+ DB_CXX_NO_EXCEPTIONS => DEFINE,
+ DB_DBT_REALLOC => IGNORE,
+ DB_DUPCURSOR => DEFINE,
+ DB_ENV_CREATE => DEFINE,
+ DB_ENV_DBLOCAL => DEFINE,
+ DB_ENV_LOCKDOWN => DEFINE,
+ DB_ENV_LOCKING => DEFINE,
+ DB_ENV_LOGGING => DEFINE,
+ DB_ENV_NOMMAP => DEFINE,
+ DB_ENV_OPEN_CALLED => DEFINE,
+ DB_ENV_PRIVATE => DEFINE,
+ DB_ENV_SYSTEM_MEM => DEFINE,
+ DB_ENV_TXN => DEFINE,
+ DB_ENV_TXN_NOSYNC => DEFINE,
+ DB_ENV_USER_ALLOC => DEFINE,
+ DB_FORCE => DEFINE,
+ DB_LOCKDOWN => DEFINE,
+ DB_LOCK_RECORD => DEFINE,
+ DB_LOGFILEID_INVALID => DEFINE,
+ DB_MPOOL_NEW_GROUP => DEFINE,
+ DB_NEXT_NODUP => DEFINE,
+ DB_OK_BTREE => DEFINE,
+ DB_OK_HASH => DEFINE,
+ DB_OK_QUEUE => DEFINE,
+ DB_OK_RECNO => DEFINE,
+ DB_OLD_VERSION => DEFINE,
+ DB_OPEN_CALLED => DEFINE,
+ DB_PAGE_LOCK => DEFINE,
+ DB_POSITION => DEFINE,
+ DB_POSITIONI => DEFINE,
+ DB_PRIVATE => DEFINE,
+ DB_QAMMAGIC => DEFINE,
+ DB_QAMOLDVER => DEFINE,
+ DB_QAMVERSION => DEFINE,
+ DB_RECORD_LOCK => DEFINE,
+ DB_REVSPLITOFF => DEFINE,
+ DB_SYSTEM_MEM => DEFINE,
+ DB_TEST_POSTLOG => DEFINE,
+ DB_TEST_POSTLOGMETA => DEFINE,
+ DB_TEST_POSTOPEN => DEFINE,
+ DB_TEST_POSTRENAME => DEFINE,
+ DB_TEST_POSTSYNC => DEFINE,
+ DB_TEST_PREOPEN => DEFINE,
+ DB_TEST_PRERENAME => DEFINE,
+ DB_TXN_NOWAIT => DEFINE,
+ DB_TXN_SYNC => DEFINE,
+ DB_UPGRADE => DEFINE,
+ DB_VERB_CHKPOINT => DEFINE,
+ DB_VERB_DEADLOCK => DEFINE,
+ DB_VERB_RECOVERY => DEFINE,
+ DB_VERB_WAITSFOR => DEFINE,
+ DB_WRITECURSOR => DEFINE,
+ DB_XA_CREATE => DEFINE,
+
+ # enum DBTYPE
+ DB_QUEUE => '3.0.55',
+
+ #########
+ # 3.1.14
+ #########
+
+ DBC_ACTIVE => IGNORE,
+ DBC_OPD => IGNORE,
+ DBC_TRANSIENT => IGNORE,
+ DBC_WRITEDUP => IGNORE,
+ DB_AGGRESSIVE => DEFINE,
+ DB_AM_DUPSORT => IGNORE,
+ DB_CACHED_COUNTS => DEFINE,
+ DB_CLIENT => DEFINE,
+ DB_DBT_DUPOK => IGNORE,
+ DB_DBT_ISSET => IGNORE,
+ DB_ENV_RPCCLIENT => DEFINE,
+ DB_GET_BOTHC => DEFINE,
+ DB_JOIN_NOSORT => DEFINE,
+ DB_NODUPDATA => DEFINE,
+ DB_NOORDERCHK => DEFINE,
+ DB_NOSERVER => DEFINE,
+ DB_NOSERVER_HOME => DEFINE,
+ DB_NOSERVER_ID => DEFINE,
+ DB_ODDFILESIZE => DEFINE,
+ DB_ORDERCHKONLY => DEFINE,
+ DB_PREV_NODUP => DEFINE,
+ DB_PR_HEADERS => DEFINE,
+ DB_PR_PAGE => DEFINE,
+ DB_PR_RECOVERYTEST => DEFINE,
+ DB_RDWRMASTER => DEFINE,
+ DB_SALVAGE => DEFINE,
+ DB_VERIFY_BAD => DEFINE,
+ DB_VERIFY_FATAL => DEFINE,
+ DB_VRFY_FLAGMASK => DEFINE,
+
+ # enum db_recops
+ DB_TXN_ABORT => '3.1.14',
+ DB_TXN_BACKWARD_ROLL => '3.1.14',
+ DB_TXN_FORWARD_ROLL => '3.1.14',
+ DB_TXN_OPENFILES => '3.1.14',
+
+ #########
+ # 3.2.9
+ #########
+
+ DBC_COMPENSATE => IGNORE,
+ DB_ALREADY_ABORTED => DEFINE,
+ DB_AM_VERIFYING => IGNORE,
+ DB_CDB_ALLDB => DEFINE,
+ DB_CONSUME_WAIT => DEFINE,
+ DB_ENV_CDB_ALLDB => DEFINE,
+ DB_EXTENT => DEFINE,
+ DB_JAVA_CALLBACK => DEFINE,
+ DB_JOINENV => DEFINE,
+ DB_LOCK_SWITCH => DEFINE,
+ DB_MPOOL_EXTENT => DEFINE,
+ DB_REGION_MAGIC => DEFINE,
+ DB_VERIFY => DEFINE,
+
+ # enum db_lockmode_t
+ DB_LOCK_WAIT => IGNORE, # 3.2.9
+
+ #########
+ # 4.0.14
+ #########
+
+ DBC_DIRTY_READ => IGNORE,
+ DBC_MULTIPLE => IGNORE,
+ DBC_MULTIPLE_KEY => IGNORE,
+ DB_AM_DIRTY => IGNORE,
+ DB_AM_SECONDARY => IGNORE,
+ DB_APPLY_LOGREG => DEFINE,
+ DB_CL_WRITER => DEFINE,
+ DB_COMMIT => DEFINE,
+ DB_DBT_APPMALLOC => IGNORE,
+ DB_DIRTY_READ => DEFINE,
+ DB_DONOTINDEX => DEFINE,
+ DB_EID_BROADCAST => DEFINE,
+ DB_EID_INVALID => DEFINE,
+ DB_ENV_NOLOCKING => DEFINE,
+ DB_ENV_NOPANIC => DEFINE,
+ DB_ENV_REGION_INIT => DEFINE,
+ DB_ENV_REP_CLIENT => DEFINE,
+ DB_ENV_REP_LOGSONLY => DEFINE,
+ DB_ENV_REP_MASTER => DEFINE,
+ DB_ENV_RPCCLIENT_GIVEN => DEFINE,
+ DB_ENV_YIELDCPU => DEFINE,
+ DB_FAST_STAT => DEFINE,
+ DB_GET_BOTH_RANGE => DEFINE,
+ DB_LOCK_EXPIRE => DEFINE,
+ DB_LOCK_FREE_LOCKER => DEFINE,
+ DB_LOCK_MAXLOCKS => DEFINE,
+ DB_LOCK_MINLOCKS => DEFINE,
+ DB_LOCK_MINWRITE => DEFINE,
+ DB_LOCK_SET_TIMEOUT => DEFINE,
+ DB_LOGC_BUF_SIZE => DEFINE,
+ DB_LOG_DISK => DEFINE,
+ DB_LOG_LOCKED => DEFINE,
+ DB_LOG_SILENT_ERR => DEFINE,
+ DB_MULTIPLE => DEFINE,
+ DB_MULTIPLE_KEY => DEFINE,
+ DB_NOLOCKING => DEFINE,
+ DB_NOPANIC => DEFINE,
+ DB_PAGE_NOTFOUND => DEFINE,
+ DB_PANIC_ENVIRONMENT => DEFINE,
+ DB_REP_CLIENT => DEFINE,
+ DB_REP_DUPMASTER => DEFINE,
+ DB_REP_HOLDELECTION => DEFINE,
+ DB_REP_LOGSONLY => DEFINE,
+ DB_REP_MASTER => DEFINE,
+ DB_REP_NEWMASTER => DEFINE,
+ DB_REP_NEWSITE => DEFINE,
+ DB_REP_OUTDATED => DEFINE,
+ DB_REP_PERMANENT => DEFINE,
+ DB_REP_UNAVAIL => DEFINE,
+ DB_RPC_SERVERPROG => DEFINE,
+ DB_RPC_SERVERVERS => DEFINE,
+ DB_SECONDARY_BAD => DEFINE,
+ DB_SET_LOCK_TIMEOUT => DEFINE,
+ DB_SET_TXN_NOW => DEFINE,
+ DB_SET_TXN_TIMEOUT => DEFINE,
+ DB_STAT_CLEAR => DEFINE,
+ DB_SURPRISE_KID => DEFINE,
+ DB_TEST_POSTDESTROY => DEFINE,
+ DB_TEST_PREDESTROY => DEFINE,
+ DB_TIMEOUT => DEFINE,
+ DB_UPDATE_SECONDARY => DEFINE,
+ DB_VERB_REPLICATION => DEFINE,
+ DB_XIDDATASIZE => DEFINE,
+ DB_YIELDCPU => DEFINE,
+ MP_FLUSH => IGNORE,
+ MP_OPEN_CALLED => IGNORE,
+ MP_READONLY => IGNORE,
+ MP_UPGRADE => IGNORE,
+ MP_UPGRADE_FAIL => IGNORE,
+ TXN_CHILDCOMMIT => IGNORE,
+ TXN_COMPENSATE => IGNORE,
+ TXN_DIRTY_READ => IGNORE,
+ TXN_LOCKTIMEOUT => IGNORE,
+ TXN_MALLOC => IGNORE,
+ TXN_NOSYNC => IGNORE,
+ TXN_NOWAIT => IGNORE,
+ TXN_SYNC => IGNORE,
+
+ # enum db_recops
+ DB_TXN_APPLY => '4.0.14',
+ DB_TXN_POPENFILES => '4.0.14',
+
+ # enum db_lockmode_t
+ DB_LOCK_DIRTY => IGNORE, # 4.0.14
+ DB_LOCK_WWRITE => IGNORE, # 4.0.14
+
+ # enum db_lockop_t
+ DB_LOCK_GET_TIMEOUT => '4.0.14',
+ DB_LOCK_PUT_READ => '4.0.14',
+ DB_LOCK_TIMEOUT => '4.0.14',
+ DB_LOCK_UPGRADE_WRITE => '4.0.14',
+
+ # enum db_status_t
+ DB_LSTAT_EXPIRED => IGNORE, # 4.0.14
+
+ #########
+ # 4.1.24
+ #########
+
+ DBC_OWN_LID => IGNORE,
+ DB_AM_CHKSUM => IGNORE,
+ DB_AM_CL_WRITER => IGNORE,
+ DB_AM_COMPENSATE => IGNORE,
+ DB_AM_CREATED => IGNORE,
+ DB_AM_CREATED_MSTR => IGNORE,
+ DB_AM_DBM_ERROR => IGNORE,
+ DB_AM_DELIMITER => IGNORE,
+ DB_AM_ENCRYPT => IGNORE,
+ DB_AM_FIXEDLEN => IGNORE,
+ DB_AM_IN_RENAME => IGNORE,
+ DB_AM_OPEN_CALLED => IGNORE,
+ DB_AM_PAD => IGNORE,
+ DB_AM_RECNUM => IGNORE,
+ DB_AM_RENUMBER => IGNORE,
+ DB_AM_REVSPLITOFF => IGNORE,
+ DB_AM_SNAPSHOT => IGNORE,
+ DB_AUTO_COMMIT => DEFINE,
+ DB_CHKSUM_SHA1 => DEFINE,
+ DB_DIRECT => DEFINE,
+ DB_DIRECT_DB => DEFINE,
+ DB_DIRECT_LOG => DEFINE,
+ DB_ENCRYPT => DEFINE,
+ DB_ENCRYPT_AES => DEFINE,
+ DB_ENV_AUTO_COMMIT => DEFINE,
+ DB_ENV_DIRECT_DB => DEFINE,
+ DB_ENV_DIRECT_LOG => DEFINE,
+ DB_ENV_FATAL => DEFINE,
+ DB_ENV_OVERWRITE => DEFINE,
+ DB_ENV_TXN_WRITE_NOSYNC => DEFINE,
+ DB_HANDLE_LOCK => DEFINE,
+ DB_LOCK_NOTEXIST => DEFINE,
+ DB_LOCK_REMOVE => DEFINE,
+ DB_NOCOPY => DEFINE,
+ DB_OVERWRITE => DEFINE,
+ DB_PERMANENT => DEFINE,
+ DB_PRINTABLE => DEFINE,
+ DB_RENAMEMAGIC => DEFINE,
+ DB_TEST_ELECTINIT => DEFINE,
+ DB_TEST_ELECTSEND => DEFINE,
+ DB_TEST_ELECTVOTE1 => DEFINE,
+ DB_TEST_ELECTVOTE2 => DEFINE,
+ DB_TEST_ELECTWAIT1 => DEFINE,
+ DB_TEST_ELECTWAIT2 => DEFINE,
+ DB_TEST_SUBDB_LOCKS => DEFINE,
+ DB_TXN_LOCK => DEFINE,
+ DB_TXN_WRITE_NOSYNC => DEFINE,
+ DB_WRITEOPEN => DEFINE,
+ DB_WRNOSYNC => DEFINE,
+ _DB_EXT_PROT_IN_ => IGNORE,
+
+ # enum db_lockop_t
+ DB_LOCK_TRADE => '4.1.24',
+
+ # enum db_status_t
+ DB_LSTAT_NOTEXIST => IGNORE, # 4.1.24
+
+ # enum DB_CACHE_PRIORITY
+ DB_PRIORITY_VERY_LOW => '4.1.24',
+ DB_PRIORITY_LOW => '4.1.24',
+ DB_PRIORITY_DEFAULT => '4.1.24',
+ DB_PRIORITY_HIGH => '4.1.24',
+ DB_PRIORITY_VERY_HIGH => '4.1.24',
+
+ # enum db_recops
+ DB_TXN_PRINT => '4.1.24',
+
+ #########
+ # 4.2.50
+ #########
+
+ DB_AM_NOT_DURABLE => IGNORE,
+ DB_AM_REPLICATION => IGNORE,
+ DB_ARCH_REMOVE => DEFINE,
+ DB_CHKSUM => DEFINE,
+ DB_ENV_LOG_AUTOREMOVE => DEFINE,
+ DB_ENV_TIME_NOTGRANTED => DEFINE,
+ DB_ENV_TXN_NOT_DURABLE => DEFINE,
+ DB_FILEOPEN => DEFINE,
+ DB_INIT_REP => DEFINE,
+ DB_LOG_AUTOREMOVE => DEFINE,
+ DB_LOG_CHKPNT => DEFINE,
+ DB_LOG_COMMIT => DEFINE,
+ DB_LOG_NOCOPY => DEFINE,
+ DB_LOG_NOT_DURABLE => DEFINE,
+ DB_LOG_PERM => DEFINE,
+ DB_LOG_WRNOSYNC => DEFINE,
+ DB_MPOOL_NOFILE => DEFINE,
+ DB_MPOOL_UNLINK => DEFINE,
+ DB_NO_AUTO_COMMIT => DEFINE,
+ DB_REP_CREATE => DEFINE,
+ DB_REP_HANDLE_DEAD => DEFINE,
+ DB_REP_ISPERM => DEFINE,
+ DB_REP_NOBUFFER => DEFINE,
+ DB_REP_NOTPERM => DEFINE,
+ DB_RPCCLIENT => DEFINE,
+ DB_TIME_NOTGRANTED => DEFINE,
+ DB_TXN_NOT_DURABLE => DEFINE,
+ DB_debug_FLAG => DEFINE,
+ DB_user_BEGIN => DEFINE,
+ MP_FILEID_SET => IGNORE,
+ TXN_RESTORED => IGNORE,
+
+ #########
+ # 4.3.21
+ #########
+
+ DBC_DEGREE_2 => IGNORE,
+ DB_AM_INORDER => IGNORE,
+ DB_BUFFER_SMALL => DEFINE,
+ DB_DEGREE_2 => DEFINE,
+ DB_DSYNC_LOG => DEFINE,
+ DB_DURABLE_UNKNOWN => DEFINE,
+ DB_ENV_DSYNC_LOG => DEFINE,
+ DB_ENV_LOG_INMEMORY => DEFINE,
+ DB_INORDER => DEFINE,
+ DB_LOCK_ABORT => DEFINE,
+ DB_LOCK_MAXWRITE => DEFINE,
+ DB_LOG_BUFFER_FULL => DEFINE,
+ DB_LOG_INMEMORY => DEFINE,
+ DB_LOG_RESEND => DEFINE,
+ DB_MPOOL_FREE => DEFINE,
+ DB_REP_EGENCHG => DEFINE,
+ DB_REP_LOGREADY => DEFINE,
+ DB_REP_PAGEDONE => DEFINE,
+ DB_REP_STARTUPDONE => DEFINE,
+ DB_SEQUENCE_VERSION => DEFINE,
+ DB_SEQ_DEC => DEFINE,
+ DB_SEQ_INC => DEFINE,
+ DB_SEQ_RANGE_SET => DEFINE,
+ DB_SEQ_WRAP => DEFINE,
+ DB_STAT_ALL => DEFINE,
+ DB_STAT_LOCK_CONF => DEFINE,
+ DB_STAT_LOCK_LOCKERS => DEFINE,
+ DB_STAT_LOCK_OBJECTS => DEFINE,
+ DB_STAT_LOCK_PARAMS => DEFINE,
+ DB_STAT_MEMP_HASH => DEFINE,
+ DB_STAT_SUBSYSTEM => DEFINE,
+ DB_UNREF => DEFINE,
+ DB_VERSION_MISMATCH => DEFINE,
+ TXN_DEADLOCK => IGNORE,
+ TXN_DEGREE_2 => IGNORE,
+
+ #########
+ # 4.3.28
+ #########
+
+ DB_SEQUENCE_OLDVER => DEFINE,
+
+ #########
+ # 4.4.16
+ #########
+
+ DBC_READ_COMMITTED => IGNORE,
+ DBC_READ_UNCOMMITTED => IGNORE,
+ DB_AM_READ_UNCOMMITTED => IGNORE,
+ DB_ASSOC_IMMUTABLE_KEY => DEFINE,
+ DB_COMPACT_FLAGS => DEFINE,
+ DB_DSYNC_DB => DEFINE,
+ DB_ENV_DSYNC_DB => DEFINE,
+ DB_FREELIST_ONLY => DEFINE,
+ DB_FREE_SPACE => DEFINE,
+ DB_IMMUTABLE_KEY => DEFINE,
+ DB_MUTEX_ALLOCATED => DEFINE,
+ DB_MUTEX_LOCKED => DEFINE,
+ DB_MUTEX_LOGICAL_LOCK => DEFINE,
+ DB_MUTEX_SELF_BLOCK => DEFINE,
+ DB_MUTEX_THREAD => DEFINE,
+ DB_READ_COMMITTED => DEFINE,
+ DB_READ_UNCOMMITTED => DEFINE,
+ DB_REGISTER => DEFINE,
+ DB_REP_ANYWHERE => DEFINE,
+ DB_REP_BULKOVF => DEFINE,
+ DB_REP_CONF_BULK => DEFINE,
+ DB_REP_CONF_DELAYCLIENT => DEFINE,
+ DB_REP_CONF_NOAUTOINIT => DEFINE,
+ DB_REP_CONF_NOWAIT => DEFINE,
+ DB_REP_IGNORE => DEFINE,
+ DB_REP_JOIN_FAILURE => DEFINE,
+ DB_REP_LOCKOUT => DEFINE,
+ DB_REP_REREQUEST => DEFINE,
+ DB_SEQ_WRAPPED => DEFINE,
+ DB_THREADID_STRLEN => DEFINE,
+ DB_VERB_REGISTER => DEFINE,
+ TXN_READ_COMMITTED => IGNORE,
+ TXN_READ_UNCOMMITTED => IGNORE,
+ TXN_SYNC_FLAGS => IGNORE,
+ TXN_WRITE_NOSYNC => IGNORE,
+
+ # enum db_lockmode_t
+ DB_LOCK_READ_UNCOMMITTED => IGNORE, # 4.4.16
+
+ #########
+ # 4.5.20
+ #########
+
+ DBC_DONTLOCK => IGNORE,
+ DB_DBT_USERCOPY => IGNORE,
+ DB_ENV_MULTIVERSION => DEFINE,
+ DB_ENV_TXN_SNAPSHOT => DEFINE,
+ DB_EVENT_NO_SUCH_EVENT => DEFINE,
+ DB_EVENT_PANIC => DEFINE,
+ DB_EVENT_REP_CLIENT => DEFINE,
+ DB_EVENT_REP_MASTER => DEFINE,
+ DB_EVENT_REP_NEWMASTER => DEFINE,
+ DB_EVENT_REP_STARTUPDONE => DEFINE,
+ DB_EVENT_WRITE_FAILED => DEFINE,
+ DB_MPOOL_EDIT => DEFINE,
+ DB_MULTIVERSION => DEFINE,
+ DB_MUTEX_PROCESS_ONLY => DEFINE,
+ DB_REPMGR_ACKS_ALL => DEFINE,
+ DB_REPMGR_ACKS_ALL_PEERS => DEFINE,
+ DB_REPMGR_ACKS_NONE => DEFINE,
+ DB_REPMGR_ACKS_ONE => DEFINE,
+ DB_REPMGR_ACKS_ONE_PEER => DEFINE,
+ DB_REPMGR_ACKS_QUORUM => DEFINE,
+ DB_REPMGR_CONNECTED => DEFINE,
+ DB_REPMGR_DISCONNECTED => DEFINE,
+ DB_REPMGR_PEER => DEFINE,
+ DB_REP_ACK_TIMEOUT => DEFINE,
+ DB_REP_CONNECTION_RETRY => DEFINE,
+ DB_REP_ELECTION => DEFINE,
+ DB_REP_ELECTION_RETRY => DEFINE,
+ DB_REP_ELECTION_TIMEOUT => DEFINE,
+ DB_REP_FULL_ELECTION => DEFINE,
+ DB_STAT_NOERROR => DEFINE,
+ DB_TEST_RECYCLE => DEFINE,
+ DB_TXN_SNAPSHOT => DEFINE,
+ DB_USERCOPY_GETDATA => DEFINE,
+ DB_USERCOPY_SETDATA => DEFINE,
+ MP_MULTIVERSION => IGNORE,
+ TXN_ABORTED => IGNORE,
+ TXN_CDSGROUP => IGNORE,
+ TXN_COMMITTED => IGNORE,
+ TXN_PREPARED => IGNORE,
+ TXN_PRIVATE => IGNORE,
+ TXN_RUNNING => IGNORE,
+ TXN_SNAPSHOT => IGNORE,
+ TXN_XA_ABORTED => IGNORE,
+ TXN_XA_DEADLOCKED => IGNORE,
+ TXN_XA_ENDED => IGNORE,
+ TXN_XA_PREPARED => IGNORE,
+ TXN_XA_STARTED => IGNORE,
+ TXN_XA_SUSPENDED => IGNORE,
+
+ #########
+ # 4.6.18
+ #########
+
+ DB_CKP_INTERNAL => DEFINE,
+ DB_DBT_MULTIPLE => IGNORE,
+ DB_ENV_NO_OUTPUT_SET => DEFINE,
+ DB_ENV_RECOVER_FATAL => DEFINE,
+ DB_ENV_REF_COUNTED => DEFINE,
+ DB_ENV_TXN_NOWAIT => DEFINE,
+ DB_EVENT_NOT_HANDLED => DEFINE,
+ DB_EVENT_REP_ELECTED => DEFINE,
+ DB_EVENT_REP_PERM_FAILED => DEFINE,
+ DB_IGNORE_LEASE => DEFINE,
+ DB_PREV_DUP => DEFINE,
+ DB_REPFLAGS_MASK => DEFINE,
+ DB_REP_CHECKPOINT_DELAY => DEFINE,
+ DB_REP_DEFAULT_PRIORITY => DEFINE,
+ DB_REP_FULL_ELECTION_TIMEOUT => DEFINE,
+ DB_REP_LEASE_EXPIRED => DEFINE,
+ DB_REP_LEASE_TIMEOUT => DEFINE,
+ DB_SPARE_FLAG => DEFINE,
+ DB_TXN_WAIT => DEFINE,
+ DB_VERB_FILEOPS => DEFINE,
+ DB_VERB_FILEOPS_ALL => DEFINE,
+
+ # enum DB_CACHE_PRIORITY
+ DB_PRIORITY_UNCHANGED => '4.6.18',
+
+ #########
+ # 4.7.25
+ #########
+
+ DBC_DUPLICATE => IGNORE,
+ DB_FOREIGN_ABORT => DEFINE,
+ DB_FOREIGN_CASCADE => DEFINE,
+ DB_FOREIGN_CONFLICT => DEFINE,
+ DB_FOREIGN_NULLIFY => DEFINE,
+ DB_LOG_AUTO_REMOVE => DEFINE,
+ DB_LOG_DIRECT => DEFINE,
+ DB_LOG_DSYNC => DEFINE,
+ DB_LOG_IN_MEMORY => DEFINE,
+ DB_LOG_ZERO => DEFINE,
+ DB_MPOOL_NOLOCK => DEFINE,
+ DB_REPMGR_CONF_2SITE_STRICT => DEFINE,
+ DB_REP_CONF_LEASE => DEFINE,
+ DB_REP_HEARTBEAT_MONITOR => DEFINE,
+ DB_REP_HEARTBEAT_SEND => DEFINE,
+ DB_SA_SKIPFIRSTKEY => DEFINE,
+ DB_STAT_MEMP_NOERROR => DEFINE,
+ DB_ST_DUPOK => DEFINE,
+ DB_ST_DUPSET => DEFINE,
+ DB_ST_DUPSORT => DEFINE,
+ DB_ST_IS_RECNO => DEFINE,
+ DB_ST_OVFL_LEAF => DEFINE,
+ DB_ST_RECNUM => DEFINE,
+ DB_ST_RELEN => DEFINE,
+ DB_ST_TOPLEVEL => DEFINE,
+ DB_VERB_REPMGR_CONNFAIL => DEFINE,
+ DB_VERB_REPMGR_MISC => DEFINE,
+ DB_VERB_REP_ELECT => DEFINE,
+ DB_VERB_REP_LEASE => DEFINE,
+ DB_VERB_REP_MISC => DEFINE,
+ DB_VERB_REP_MSGS => DEFINE,
+ DB_VERB_REP_SYNC => DEFINE,
+ MP_DUMMY => IGNORE,
+
+ #########
+ # 4.8.24
+ #########
+
+ DBC_BULK => IGNORE,
+ DBC_DOWNREV => IGNORE,
+ DBC_FROM_DB_GET => IGNORE,
+ DBC_PARTITIONED => IGNORE,
+ DBC_WAS_READ_COMMITTED => IGNORE,
+ DB_AM_COMPRESS => IGNORE,
+ DB_CURSOR_BULK => DEFINE,
+ DB_CURSOR_TRANSIENT => DEFINE,
+ DB_DBT_BULK => IGNORE,
+ DB_DBT_STREAMING => IGNORE,
+ DB_ENV_FAILCHK => DEFINE,
+ DB_EVENT_REG_ALIVE => DEFINE,
+ DB_EVENT_REG_PANIC => DEFINE,
+ DB_FAILCHK => DEFINE,
+ DB_GET_BOTH_LTE => DEFINE,
+ DB_GID_SIZE => DEFINE,
+ DB_LOGCHKSUM => DEFINE,
+ DB_LOGVERSION_LATCHING => DEFINE,
+ DB_MPOOL_TRY => DEFINE,
+ DB_MUTEX_SHARED => DEFINE,
+ DB_OVERWRITE_DUP => DEFINE,
+ DB_REP_CONF_INMEM => DEFINE,
+ DB_REP_PAGELOCKED => DEFINE,
+ DB_SA_UNKNOWNKEY => DEFINE,
+ DB_SET_LTE => DEFINE,
+ DB_SET_REG_TIMEOUT => DEFINE,
+ DB_SHALLOW_DUP => DEFINE,
+ DB_VERB_REP_TEST => DEFINE,
+ DB_VERIFY_PARTITION => DEFINE,
+
+ #########
+ # 5.0.6
+ #########
+
+ DBC_FAMILY => IGNORE,
+ DB_EVENT_REP_DUPMASTER => DEFINE,
+ DB_EVENT_REP_ELECTION_FAILED => DEFINE,
+ DB_EVENT_REP_JOIN_FAILURE => DEFINE,
+ DB_EVENT_REP_MASTER_FAILURE => DEFINE,
+ DB_FORCESYNC => DEFINE,
+ DB_LOG_VERIFY_BAD => DEFINE,
+ DB_LOG_VERIFY_CAF => DEFINE,
+ DB_LOG_VERIFY_DBFILE => DEFINE,
+ DB_LOG_VERIFY_ERR => DEFINE,
+ DB_LOG_VERIFY_FORWARD => DEFINE,
+ DB_LOG_VERIFY_INTERR => DEFINE,
+ DB_LOG_VERIFY_VERBOSE => DEFINE,
+ DB_LOG_VERIFY_WARNING => DEFINE,
+ DB_REPMGR_CONF_ELECTIONS => DEFINE,
+ DB_REPMGR_ISPEER => DEFINE,
+ DB_REP_CONF_AUTOINIT => DEFINE,
+ DB_TXN_FAMILY => DEFINE,
+ DB_TXN_TOKEN_SIZE => DEFINE,
+ DB_VERB_REP_SYSTEM => DEFINE,
+ DB_VERSION_FAMILY => DEFINE,
+ DB_VERSION_FULL_STRING => STRING,
+ DB_VERSION_RELEASE => DEFINE,
+ TXN_FAMILY => IGNORE,
+ TXN_IGNORE_LEASE => IGNORE,
+ TXN_INFAMILY => IGNORE,
+ TXN_READONLY => IGNORE,
+
+ # enum log_rec_type_t
+ LOGREC_Done => '5.0.6',
+ LOGREC_ARG => '5.0.6',
+ LOGREC_HDR => '5.0.6',
+ LOGREC_DATA => '5.0.6',
+ LOGREC_DB => '5.0.6',
+ LOGREC_DBOP => '5.0.6',
+ LOGREC_DBT => '5.0.6',
+ LOGREC_LOCKS => '5.0.6',
+ LOGREC_OP => '5.0.6',
+ LOGREC_PGDBT => '5.0.6',
+ LOGREC_PGDDBT => '5.0.6',
+ LOGREC_PGLIST => '5.0.6',
+ LOGREC_POINTER => '5.0.6',
+ LOGREC_TIME => '5.0.6',
+
+ # enum db_recops
+ DB_TXN_LOG_VERIFY => '5.0.6',
+
+ #########
+ # 5.0.32
+ #########
+
+ DBC_ERROR => IGNORE,
+ DB_LOG_VERIFY_PARTIAL => DEFINE,
+ DB_NOERROR => DEFINE,
+
+ #########
+ # 5.1.3
+ #########
+
+ DB_ASSOC_CREATE => DEFINE,
+ DB_DATABASE_LOCK => DEFINE,
+ DB_DATABASE_LOCKING => DEFINE,
+ DB_ENV_DATABASE_LOCKING => DEFINE,
+ DB_ENV_HOTBACKUP => DEFINE,
+ DB_HOTBACKUP_IN_PROGRESS => DEFINE,
+ DB_LOCK_CHECK => DEFINE,
+ DB_LOG_NO_DATA => DEFINE,
+ DB_REPMGR_ACKS_ALL_AVAILABLE => DEFINE,
+ DB_TXN_BULK => DEFINE,
+ TXN_BULK => IGNORE,
+
+ #########
+ # 5.1.18
+ #########
+
+ DB_ENV_NOFLUSH => DEFINE,
+ DB_NOFLUSH => DEFINE,
+ DB_NO_CHECKPOINT => DEFINE,
+
+ #########
+ # 5.2.14
+ #########
+
+ DB_ALIGN8 => IGNORE,
+ DB_BOOTSTRAP_HELPER => DEFINE,
+ DB_DBT_READONLY => IGNORE,
+ DB_EID_MASTER => DEFINE,
+ DB_EVENT_REP_CONNECT_BROKEN => DEFINE,
+ DB_EVENT_REP_CONNECT_ESTD => DEFINE,
+ DB_EVENT_REP_CONNECT_TRY_FAILED => DEFINE,
+ DB_EVENT_REP_INIT_DONE => DEFINE,
+ DB_EVENT_REP_LOCAL_SITE_REMOVED => DEFINE,
+ DB_EVENT_REP_SITE_ADDED => DEFINE,
+ DB_EVENT_REP_SITE_REMOVED => DEFINE,
+ DB_EVENT_REP_WOULD_ROLLBACK => DEFINE,
+ DB_FAILCHK_ISALIVE => DEFINE,
+ DB_GROUP_CREATOR => DEFINE,
+ DB_HEAPMAGIC => DEFINE,
+ DB_HEAPOLDVER => DEFINE,
+ DB_HEAPVERSION => DEFINE,
+ DB_HEAP_FULL => DEFINE,
+ DB_HEAP_RID_SZ => DEFINE,
+ DB_INIT_MUTEX => DEFINE,
+ DB_INTERNAL_DB => DEFINE,
+ DB_LEGACY => DEFINE,
+ DB_LOCAL_SITE => DEFINE,
+ DB_OK_HEAP => DEFINE,
+ DB_REPMGR_NEED_RESPONSE => DEFINE,
+ DB_REP_CONF_AUTOROLLBACK => DEFINE,
+ DB_REP_WOULDROLLBACK => DEFINE,
+ DB_STAT_ALLOC => DEFINE,
+ DB_STAT_SUMMARY => DEFINE,
+ TXN_NEED_ABORT => IGNORE,
+ TXN_XA_ACTIVE => IGNORE,
+ TXN_XA_IDLE => IGNORE,
+ TXN_XA_ROLLEDBACK => IGNORE,
+ TXN_XA_THREAD_ASSOCIATED => IGNORE,
+ TXN_XA_THREAD_NOTA => IGNORE,
+ TXN_XA_THREAD_SUSPENDED => IGNORE,
+ TXN_XA_THREAD_UNASSOCIATED => IGNORE,
+
+ # enum DBTYPE
+ DB_HEAP => '5.2.14',
+
+ # enum DB_MEM_CONFIG
+ DB_MEM_LOCK => '5.2.14',
+ DB_MEM_LOCKOBJECT => '5.2.14',
+ DB_MEM_LOCKER => '5.2.14',
+ DB_MEM_LOGID => '5.2.14',
+ DB_MEM_TRANSACTION => '5.2.14',
+ DB_MEM_THREAD => '5.2.14',
+
+ #########
+ # 5.3.5
+ #########
+
+ DB2_AM_EXCL => DEFINE,
+ DB2_AM_INTEXCL => DEFINE,
+ DB2_AM_NOWAIT => DEFINE,
+ DB_AM_PARTDB => IGNORE,
+ DB_BACKUP_CLEAN => DEFINE,
+ DB_BACKUP_FILES => DEFINE,
+ DB_BACKUP_NO_LOGS => DEFINE,
+ DB_BACKUP_SINGLE_DIR => DEFINE,
+ DB_BACKUP_UPDATE => DEFINE,
+ DB_INTERNAL_PERSISTENT_DB => DEFINE,
+ DB_INTERNAL_TEMPORARY_DB => DEFINE,
+ DB_LOCK_IGNORE_REC => DEFINE,
+ DB_VERB_BACKUP => DEFINE,
+
+ # enum DB_BACKUP_CONFIG
+ DB_BACKUP_READ_COUNT => '5.3.5',
+ DB_BACKUP_READ_SLEEP => '5.3.5',
+ DB_BACKUP_SIZE => '5.3.5',
+ DB_BACKUP_WRITE_DIRECT => '5.3.5',
+ ) ;
+
+sub enum_Macro
+{
+ my $str = shift ;
+ my ($major, $minor, $patch) = split /\./, $str ;
+
+ my $macro =
+ "#if (DB_VERSION_MAJOR > $major) || \\\n" .
+ " (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR > $minor) || \\\n" .
+ " (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR == $minor && \\\n" .
+ " DB_VERSION_PATCH >= $patch)\n" ;
+
+ return $macro;
+
+}
+
+sub OutputXS
+{
+
+ my @names = () ;
+
+ foreach my $key (sort keys %constants)
+ {
+ my $val = $constants{$key} ;
+ next if $val eq IGNORE;
+
+ if ($val eq STRING)
+ { push @names, { name => $key, type => "PV" } }
+ elsif ($val eq DEFINE)
+ { push @names, $key }
+ else
+ { push @names, { name => $key, macro => [enum_Macro($val), "#endif\n"] } }
+ }
+
+ warn "Updating constants.xs & constants.h...\n";
+ WriteConstants(
+ NAME => BerkeleyDB,
+ NAMES => \@names,
+ C_FILE => 'constants.h',
+ XS_FILE => 'constants.xs',
+ ) ;
+}
+
+sub OutputPM
+{
+ my $filename = 'BerkeleyDB.pm';
+ warn "Updating $filename...\n";
+ open IN, "<$filename" || die "Cannot open $filename: $!\n";
+ open OUT, ">$filename.tmp" || die "Cannot open $filename.tmp: $!\n";
+
+ my $START = '@EXPORT = qw(' ;
+ my $START_re = quotemeta $START ;
+ my $END = ');';
+ my $END_re = quotemeta $END ;
+
+ # skip to the @EXPORT declaration
+ OUTER: while (<IN>)
+ {
+ if ( /^\s*$START_re/ )
+ {
+ # skip to the end marker.
+ while (<IN>)
+ { last OUTER if /^\s*$END_re/ }
+ }
+ print OUT ;
+ }
+
+ print OUT "$START\n";
+ foreach my $key (sort keys %constants)
+ {
+ next if $constants{$key} eq IGNORE;
+ print OUT "\t$key\n";
+ }
+ print OUT "\t$END\n";
+
+ while (<IN>)
+ {
+ print OUT ;
+ }
+
+ close IN;
+ close OUT;
+
+ rename $filename, "$filename.bak" || die "Cannot rename $filename: $!\n" ;
+ rename "$filename.tmp", $filename || die "Cannot rename $filename.tmp: $!\n" ;
+}
+
+OutputXS() ;
+OutputPM() ;
diff --git a/lang/perl/BerkeleyDB/mkpod b/lang/perl/BerkeleyDB/mkpod
new file mode 100755
index 00000000..44bbf3fb
--- /dev/null
+++ b/lang/perl/BerkeleyDB/mkpod
@@ -0,0 +1,146 @@
+#!/usr/local/bin/perl5
+
+# Filename: mkpod
+#
+# Author: Paul Marquess
+
+# File types
+#
+# Macro files end with .M
+# Tagged source files end with .T
+# Output from the code ends with .O
+# Pre-Pod file ends with .P
+#
+# Tags
+#
+# ## BEGIN tagname
+# ...
+# ## END tagname
+#
+# ## 0
+# ## 1
+#
+
+# Constants
+
+$TOKEN = '##' ;
+$Verbose = 1 if $ARGV[0] =~ /^-v/i ;
+
+# Macros files first
+foreach $file (glob("*.M"))
+{
+ open (F, "<$file") or die "Cannot open '$file':$!\n" ;
+ print " Processing Macro file $file\n" ;
+ while (<F>)
+ {
+ # Skip blank & comment lines
+ next if /^\s*$/ || /^\s*#/ ;
+
+ #
+ ($name, $expand) = split (/\t+/, $_, 2) ;
+
+ $expand =~ s/^\s*// ;
+ $expand =~ s/\s*$// ;
+
+ if ($expand =~ /\[#/ )
+ {
+ }
+
+ $Macros{$name} = $expand ;
+ }
+ close F ;
+}
+
+# Suck up all the code files
+foreach $file (glob("t/*.T"))
+{
+ ($newfile = $file) =~ s/\.T$// ;
+ open (F, "<$file") or die "Cannot open '$file':$!\n" ;
+ open (N, ">$newfile") or die "Cannot open '$newfile':$!\n" ;
+
+ print " Processing $file -> $newfile\n" ;
+
+ while ($line = <F>)
+ {
+ if ($line =~ /^$TOKEN\s*BEGIN\s+(\w+)\s*$/ or
+ $line =~ m[\s*/\*$TOKEN\s*BEGIN\s+(\w+)\s*$] )
+ {
+ print " Section $1 begins\n" if $Verbose ;
+ $InSection{$1} ++ ;
+ $Section{$1} = '' unless $Section{$1} ;
+ }
+ elsif ($line =~ /^$TOKEN\s*END\s+(\w+)\s*$/ or
+ $line =~ m[^\s*/\*$TOKEN\s*END\s+(\w+)\s*$] )
+ {
+ warn "Encountered END without a begin [$line]\n"
+ unless $InSection{$1} ;
+
+ delete $InSection{$1} ;
+ print " Section $1 ends\n" if $Verbose ;
+ }
+ else
+ {
+ print N $line ;
+ chop $line ;
+ $line =~ s/\s*$// ;
+
+ # Save the current line in each of the sections
+ foreach( keys %InSection)
+ {
+ if ($line !~ /^\s*$/ )
+ #{ $Section{$_} .= " $line" }
+ { $Section{$_} .= $line }
+ $Section{$_} .= "\n" ;
+ }
+ }
+
+ }
+
+ if (%InSection)
+ {
+ # Check for unclosed sections
+ print "The following Sections are not terminated\n" ;
+ foreach (sort keys %InSection)
+ { print "\t$_\n" }
+ exit 1 ;
+ }
+
+ close F ;
+ close N ;
+}
+
+print "\n\nCreating pod file(s)\n\n" if $Verbose ;
+
+@ppods = glob('*.P') ;
+#$ppod = $ARGV[0] ;
+#$pod = $ARGV[1] ;
+
+# Now process the pre-pod file
+foreach $ppod (@ppods)
+{
+ ($pod = $ppod) =~ s/\.P$// ;
+ open (PPOD, "<$ppod") or die "Cannot open file '$ppod': $!\n" ;
+ open (POD, ">$pod") or die "Cannot open file '$pod': $!\n" ;
+
+ print " $ppod -> $pod\n" ;
+
+ while ($line = <PPOD>)
+ {
+ if ( $line =~ /^\s*$TOKEN\s*(\w+)\s*$/)
+ {
+ warn "No code insert '$1' available\n"
+ unless $Section{$1} ;
+
+ print "Expanding section $1\n" if $Verbose ;
+ print POD $Section{$1} ;
+ }
+ else
+ {
+# $line =~ s/\[#([^\]])]/$Macros{$1}/ge ;
+ print POD $line ;
+ }
+ }
+
+ close PPOD ;
+ close POD ;
+}
diff --git a/lang/perl/BerkeleyDB/patches/5.004 b/lang/perl/BerkeleyDB/patches/5.004
new file mode 100644
index 00000000..0665d1f6
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004
@@ -0,0 +1,93 @@
+diff -rc perl5.004.orig/Configure perl5.004/Configure
+*** perl5.004.orig/Configure 1997-05-13 18:20:34.000000000 +0100
+--- perl5.004/Configure 2003-04-26 16:36:53.000000000 +0100
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9902,9907 ****
+--- 9903,9916 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10370,10375 ****
+--- 10379,10385 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004.orig/Makefile.SH perl5.004/Makefile.SH
+*** perl5.004.orig/Makefile.SH 1997-05-01 15:22:39.000000000 +0100
+--- perl5.004/Makefile.SH 2003-04-26 16:37:23.000000000 +0100
+***************
+*** 119,125 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 119,125 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004.orig/myconfig perl5.004/myconfig
+*** perl5.004.orig/myconfig 1996-12-21 01:13:20.000000000 +0000
+--- perl5.004/myconfig 2003-04-26 16:37:51.000000000 +0100
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004.orig/patchlevel.h perl5.004/patchlevel.h
+*** perl5.004.orig/patchlevel.h 1997-05-15 23:15:17.000000000 +0100
+--- perl5.004/patchlevel.h 2003-04-26 16:38:11.000000000 +0100
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.004_01 b/lang/perl/BerkeleyDB/patches/5.004_01
new file mode 100644
index 00000000..1b05eb4e
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004_01
@@ -0,0 +1,217 @@
+diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure
+*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997
+--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9907,9912 ****
+--- 9908,9921 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10375,10380 ****
+--- 10384,10390 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH
+*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997
+--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm
+*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997
+--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000
+***************
+*** 170,176 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 170,176 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm
+*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997
+--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $Verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $Verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $Verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $Verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997
+--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000
+***************
+*** 2137,2143 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2137,2143 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig
+*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h
+*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997
+--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.004_02 b/lang/perl/BerkeleyDB/patches/5.004_02
new file mode 100644
index 00000000..238f8737
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004_02
@@ -0,0 +1,217 @@
+diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure
+*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997
+--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9911,9916 ****
+--- 9912,9925 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10379,10384 ****
+--- 10388,10394 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH
+*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997
+--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm
+*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm
+*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997
+--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997
+--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000
+***************
+*** 2224,2230 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2224,2230 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig
+*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h
+*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997
+--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.004_03 b/lang/perl/BerkeleyDB/patches/5.004_03
new file mode 100644
index 00000000..06331eac
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004_03
@@ -0,0 +1,223 @@
+diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure
+*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997
+--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9911,9916 ****
+--- 9912,9925 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10379,10384 ****
+--- 10388,10394 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+Only in perl5.004_03: Configure.orig
+diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH
+*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997
+--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+Only in perl5.004_03: Makefile.SH.orig
+diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm
+*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm
+*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997
+--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig
+Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej
+diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997
+--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000
+***************
+*** 2224,2230 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2224,2230 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig
+diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig
+*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h
+*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997
+--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
+Only in perl5.004_03: patchlevel.h.orig
diff --git a/lang/perl/BerkeleyDB/patches/5.004_04 b/lang/perl/BerkeleyDB/patches/5.004_04
new file mode 100644
index 00000000..a227dc70
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004_04
@@ -0,0 +1,209 @@
+diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure
+*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997
+--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9910,9915 ****
+--- 9911,9924 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10378,10383 ****
+--- 10387,10393 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH
+*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997
+--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000
+***************
+*** 129,135 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 129,135 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm
+*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm
+*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997
+--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 189,195 ****
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 189,195 ----
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 539,545 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 539,545 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997
+--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000
+***************
+*** 2229,2235 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2229,2235 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig
+*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997
+--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h
+*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997
+--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.004_05 b/lang/perl/BerkeleyDB/patches/5.004_05
new file mode 100644
index 00000000..51c8bf35
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.004_05
@@ -0,0 +1,209 @@
+diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure
+*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000
+--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 10164,10169 ****
+--- 10165,10178 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10648,10653 ****
+--- 10657,10663 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH
+*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000
+--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000
+***************
+*** 151,157 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 151,157 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm
+*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm
+*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000
+--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 590,596 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 590,596 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000
+--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000
+***************
+*** 2246,2252 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2246,2252 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig
+*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000
+--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h
+*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000
+--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.005 b/lang/perl/BerkeleyDB/patches/5.005
new file mode 100644
index 00000000..effee3e8
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.005
@@ -0,0 +1,209 @@
+diff -rc perl5.005.orig/Configure perl5.005/Configure
+*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998
+--- perl5.005/Configure Sun Nov 12 21:30:40 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11279,11284 ****
+--- 11280,11293 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11804,11809 ****
+--- 11813,11819 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH
+*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm
+*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm
+*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998
+--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 290,296 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 290,296 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 598,604 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 598,604 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm
+*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.005.orig/myconfig perl5.005/myconfig
+*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005/myconfig Sun Nov 12 21:30:41 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h
+*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998
+--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.005_01 b/lang/perl/BerkeleyDB/patches/5.005_01
new file mode 100644
index 00000000..2a05dd54
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.005_01
@@ -0,0 +1,209 @@
+diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure
+*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998
+--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11279,11284 ****
+--- 11280,11293 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11804,11809 ****
+--- 11813,11819 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH
+*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm
+*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm
+*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998
+--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 290,296 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 290,296 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 598,604 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 598,604 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig
+*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h
+*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000
+--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.005_02 b/lang/perl/BerkeleyDB/patches/5.005_02
new file mode 100644
index 00000000..5dd57ddc
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.005_02
@@ -0,0 +1,264 @@
+diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure
+*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000
+--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11334,11339 ****
+--- 11335,11348 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11859,11864 ****
+--- 11868,11874 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+Only in perl5.005_02: Configure.orig
+diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH
+*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+Only in perl5.005_02: Makefile.SH.orig
+diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm
+*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm
+*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000
+--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 333,339 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 333,339 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 623,629 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 623,629 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+***************
+*** 666,672 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 666,672 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 676,682 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 676,682 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig
+diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig
+diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig
+*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h
+*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000
+--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000
+***************
+*** 40,45 ****
+--- 40,46 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/patches/5.005_03 b/lang/perl/BerkeleyDB/patches/5.005_03
new file mode 100644
index 00000000..115f9f5b
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.005_03
@@ -0,0 +1,250 @@
+diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure
+*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999
+--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000
+***************
+*** 208,213 ****
+--- 208,214 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11642,11647 ****
+--- 11643,11656 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 12183,12188 ****
+--- 12192,12198 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH
+*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999
+--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000
+***************
+*** 58,67 ****
+ shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
+ case "$osvers" in
+ 3*)
+! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib"
+ ;;
+ *)
+! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib"
+ ;;
+ esac
+ aixinstdir=`pwd | sed 's/\/UU$//'`
+--- 58,67 ----
+ shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
+ case "$osvers" in
+ 3*)
+! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib"
+ ;;
+ *)
+! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib"
+ ;;
+ esac
+ aixinstdir=`pwd | sed 's/\/UU$//'`
+***************
+*** 155,161 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 155,161 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm
+*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999
+--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm
+*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999
+--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 336,342 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 336,342 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 626,632 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+--- 626,632 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+***************
+*** 670,676 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 670,676 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 680,686 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 680,686 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999
+--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000
+***************
+*** 2284,2290 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2284,2290 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
diff --git a/lang/perl/BerkeleyDB/patches/5.6.0 b/lang/perl/BerkeleyDB/patches/5.6.0
new file mode 100644
index 00000000..1f9b3b62
--- /dev/null
+++ b/lang/perl/BerkeleyDB/patches/5.6.0
@@ -0,0 +1,294 @@
+diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure
+*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000
+--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000
+***************
+*** 217,222 ****
+--- 217,223 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 14971,14976 ****
+--- 14972,14985 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 15640,15645 ****
+--- 15649,15655 ----
+ path_sep='$path_sep'
+ perl5='$perl5'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH
+*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000
+--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000
+***************
+*** 70,76 ****
+ *) shrpldflags="$shrpldflags -b noentry"
+ ;;
+ esac
+! shrpldflags="$shrpldflags $ldflags $libs $cryptlib"
+ linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl"
+ ;;
+ hpux*)
+--- 70,76 ----
+ *) shrpldflags="$shrpldflags -b noentry"
+ ;;
+ esac
+! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib"
+ linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl"
+ ;;
+ hpux*)
+***************
+*** 176,182 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 176,182 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+***************
+*** 333,339 ****
+ case "$osname" in
+ aix)
+ $spitshell >>Makefile <<!GROK!THIS!
+! LIBS = $libs
+ # In AIX we need to change this for building Perl itself from
+ # its earlier definition (which is for building external
+ # extensions *after* Perl has been built and installed)
+--- 333,339 ----
+ case "$osname" in
+ aix)
+ $spitshell >>Makefile <<!GROK!THIS!
+! LIBS = $perllibs
+ # In AIX we need to change this for building Perl itself from
+ # its earlier definition (which is for building external
+ # extensions *after* Perl has been built and installed)
+diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm
+*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000
+--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000
+***************
+*** 193,199 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 193,199 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm
+*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000
+--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000
+***************
+*** 17,34 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 17,34 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 198,204 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 198,204 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 338,344 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 338,344 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 624,630 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+--- 624,630 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+***************
+*** 668,674 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 668,674 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 678,684 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 678,684 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm
+*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000
+--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000
+***************
+*** 2450,2456 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2450,2456 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH
+*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000
+--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000
+***************
+*** 48,54 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 48,54 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h
+*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000
+--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000
+***************
+*** 70,75 ****
+--- 70,76 ----
+ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/BerkeleyDB/ppport.h b/lang/perl/BerkeleyDB/ppport.h
new file mode 100644
index 00000000..0815cf2d
--- /dev/null
+++ b/lang/perl/BerkeleyDB/ppport.h
@@ -0,0 +1,349 @@
+/* This file is Based on output from
+ * Perl/Pollution/Portability Version 2.0000 */
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(d) (IV)(d)
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(d)
+#endif
+
+#ifndef dTHR
+# ifdef WIN32
+# define dTHR extern int Perl___notused
+# else
+# define dTHR extern int errno
+# endif
+#endif
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+#ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#endif
+
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if PERL_REVISION == 5 && \
+ (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+# define PERL_UNUSED_DECL __attribute__((unused))
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+
+#if 1
+#ifdef DBM_setFilter
+#undef DBM_setFilter
+#undef DBM_ckFilter
+#endif
+#endif
+
+#ifndef DBM_setFilter
+
+/*
+ The DBM_setFilter & DBM_ckFilter macros are only used by
+ the *DB*_File modules
+*/
+
+#define DBM_setFilter(db_type,code) \
+ { \
+ if (db_type) \
+ RETVAL = sv_mortalcopy(db_type) ; \
+ ST(0) = RETVAL ; \
+ if (db_type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db_type) ; \
+ db_type = NULL ; \
+ } \
+ else if (code) { \
+ if (db_type) \
+ sv_setsv(db_type, code) ; \
+ else \
+ db_type = newSVsv(code) ; \
+ } \
+ }
+
+#define DBM_ckFilter(arg,type,name) \
+ if (db->type) { \
+ /* printf("Filtering %s\n", name); */ \
+ if (db->filtering) { \
+ croak("recursion detected in %s", name) ; \
+ } \
+ ENTER ; \
+ SAVETMPS ; \
+ SAVEINT(db->filtering) ; \
+ db->filtering = TRUE ; \
+ SAVESPTR(DEFSV) ; \
+ if (name[7] == 's') \
+ arg = newSVsv(arg); \
+ DEFSV = arg ; \
+ SvTEMP_off(arg) ; \
+ PUSHMARK(SP) ; \
+ PUTBACK ; \
+ (void) perl_call_sv(db->type, G_DISCARD); \
+ arg = DEFSV ; \
+ SPAGAIN ; \
+ PUTBACK ; \
+ FREETMPS ; \
+ LEAVE ; \
+ if (name[7] == 's'){ \
+ arg = sv_2mortal(arg); \
+ } \
+ SvOKp(arg); \
+ }
+
+#endif /* DBM_setFilter */
+
+#endif /* _P_P_PORTABILITY_H_ */
diff --git a/lang/perl/BerkeleyDB/scan.pl b/lang/perl/BerkeleyDB/scan.pl
new file mode 100644
index 00000000..3fce7a8d
--- /dev/null
+++ b/lang/perl/BerkeleyDB/scan.pl
@@ -0,0 +1,241 @@
+#!/usr/local/bin/perl
+
+my $ignore_re = '^(' . join("|",
+ qw(
+ _
+ [a-z]
+ DBM
+ DBC
+ DB_AM_
+ DB_BT_
+ DB_RE_
+ DB_HS_
+ DB_FUNC_
+ DB_DBT_
+ DB_DBM
+ DB_TSL
+ MP
+ TXN
+ DB_TXN_GETPGNOS
+ DB_TXN_BACKWARD_ALLOC
+ DB_ALIGN8
+ )) . ')' ;
+
+my %ignore_def = map {$_, 1} qw() ;
+
+%ignore_enums = map {$_, 1} qw( ACTION db_status_t db_notices db_lockmode_t ) ;
+
+my %ignore_exact_enum = map { $_ => 1}
+ qw(
+ DB_TXN_GETPGNOS
+ DB_TXN_BACKWARD_ALLOC
+ );
+
+my $filler = ' ' x 26 ;
+
+chdir "libraries" || die "Cannot chdir into './libraries': $!\n";
+
+foreach my $name (sort tuple glob "[2-9]*")
+{
+ next if $name =~ /(NOHEAP|NC|private)$/;
+
+ my $inc = "$name/include/db.h" ;
+ next unless -f $inc ;
+
+ my $file = readFile($inc) ;
+ StripCommentsAndStrings($file) ;
+ my $result = scan($name, $file) ;
+ print "\n\t#########\n\t# $name\n\t#########\n\n$result"
+ if $result;
+}
+exit ;
+
+
+sub scan
+{
+ my $version = shift ;
+ my $file = shift ;
+
+ my %seen_define = () ;
+ my $result = "" ;
+
+ if (1) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $file =~ s/\?\?=/#/g; # | ??=| #|
+ $file =~ s/\?\?\!/|/g; # | ??!| ||
+ $file =~ s/\?\?'/^/g; # | ??'| ^|
+ $file =~ s/\?\?\(/[/g; # | ??(| [|
+ $file =~ s/\?\?\)/]/g; # | ??)| ]|
+ $file =~ s/\?\?\-/~/g; # | ??-| ~|
+ $file =~ s/\?\?\//\\/g; # | ??/| \|
+ $file =~ s/\?\?</{/g; # | ??<| {|
+ $file =~ s/\?\?>/}/g; # | ??>| }|
+ }
+
+ while ( $file =~ /^\s*#\s*define\s+([\$\w]+)\b(?!\()\s*(.*)/gm )
+ {
+ my $def = $1;
+ my $rest = $2;
+ my $ignore = 0 ;
+
+ $ignore = 1 if $ignore_def{$def} || $def =~ /$ignore_re/o ;
+
+ # Cannot do: (-1) and ((LHANDLE)3) are OK:
+ #print("Skip non-wordy $def => $rest\n"),
+
+ $rest =~ s/\s*$//;
+ #next if $rest =~ /[^\w\$]/;
+
+ #print "Matched $_ ($def)\n" ;
+
+ next if $before{$def} ++ ;
+
+ if ($ignore)
+ { $seen_define{$def} = 'IGNORE' }
+ elsif ($rest =~ /"/)
+ { $seen_define{$def} = 'STRING' }
+ else
+ { $seen_define{$def} = 'DEFINE' }
+ }
+
+ foreach $define (sort keys %seen_define)
+ {
+ my $out = $filler ;
+ substr($out,0, length $define) = $define;
+ $result .= "\t$out => $seen_define{$define},\n" ;
+ }
+
+ while ($file =~ /\btypedef\s+enum\s*{(.*?)}\s*(\w+)/gs )
+ {
+ my $enum = $1 ;
+ my $name = $2 ;
+ my $ignore = 0 ;
+
+ $ignore = 1 if $ignore_enums{$name} ;
+
+ #$enum =~ s/\s*=\s*\S+\s*(,?)\s*\n/$1/g;
+ $enum =~ s/^\s*//;
+ $enum =~ s/\s*$//;
+
+ my @tokens = map { s/\s*=.*// ; $_} split /\s*,\s*/, $enum ;
+ my @new = grep { ! $Enums{$_}++ } @tokens ;
+ if (@new)
+ {
+ my $value ;
+ if ($ignore)
+ { $value = "IGNORE, # $version" }
+ else
+ { $value = "'$version'," }
+
+ $result .= "\n\t# enum $name\n";
+ my $out = $filler ;
+ foreach $name (@new)
+ {
+ next if $ignore_exact_enum{$name} ;
+ $out = $filler ;
+ substr($out,0, length $name) = $name;
+ $result .= "\t$out => $value\n" ;
+ }
+ }
+ }
+
+ return $result ;
+}
+
+
+sub StripCommentsAndStrings
+{
+
+ # Strip C & C++ coments
+ # From the perlfaq
+ $_[0] =~
+
+ s{
+ /\* ## Start of /* ... */ comment
+ [^*]*\*+ ## Non-* followed by 1-or-more *'s
+ (
+ [^/*][^*]*\*+
+ )* ## 0-or-more things which don't start with /
+ ## but do end with '*'
+ / ## End of /* ... */ comment
+
+ | ## OR C++ Comment
+ // ## Start of C++ comment //
+ [^\n]* ## followed by 0-or-more non end of line characters
+
+ | ## OR various things which aren't comments:
+
+ (
+ " ## Start of " ... " string
+ (
+ \\. ## Escaped char
+ | ## OR
+ [^"\\] ## Non "\
+ )*
+ " ## End of " ... " string
+
+ | ## OR
+
+ ' ## Start of ' ... ' string
+ (
+ \\. ## Escaped char
+ | ## OR
+ [^'\\] ## Non '\
+ )*
+ ' ## End of ' ... ' string
+
+ | ## OR
+
+ . ## Anything other char
+ [^/"'\\]* ## Chars which doesn't start a comment, string or escape
+ )
+ }{$2}gxs;
+
+
+
+ # Remove double-quoted strings.
+ #$_[0] =~ s#"(\\.|[^"\\])*"##g;
+
+ # Remove single-quoted strings.
+ #$_[0] =~ s#'(\\.|[^'\\])*'##g;
+
+ # Remove leading whitespace.
+ $_[0] =~ s/\A\s+//m ;
+
+ # Remove trailing whitespace.
+ $_[0] =~ s/\s+\Z//m ;
+
+ # Replace all multiple whitespace by a single space.
+ #$_[0] =~ s/\s+/ /g ;
+}
+
+
+sub readFile
+{
+ my $filename = shift ;
+ open F, "<$filename" || die "Cannot open $filename: $!\n" ;
+ local $/ ;
+ my $x = <F> ;
+ close F ;
+ return $x ;
+}
+
+sub tuple
+{
+ my (@a) = split(/\./, $a) ;
+ my (@b) = split(/\./, $b) ;
+ if (@a != @b) {
+ my $diff = @a - @b ;
+ push @b, (0 x $diff) if $diff > 0 ;
+ push @a, (0 x -$diff) if $diff < 0 ;
+ }
+ foreach $A (@a) {
+ $B = shift @b ;
+ $A == $B or return $A <=> $B ;
+ }
+ return 0;
+}
+
+__END__
+
diff --git a/lang/perl/BerkeleyDB/t/Test/Builder.pm b/lang/perl/BerkeleyDB/t/Test/Builder.pm
new file mode 100644
index 00000000..859915b6
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/Test/Builder.pm
@@ -0,0 +1,1625 @@
+package Test::Builder;
+
+use 5.004;
+
+# $^C was only introduced in 5.005-ish. We do this to prevent
+# use of uninitialized value warnings in older perls.
+$^C ||= 0;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.30';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+ # Load threads::shared when threads are turned on
+ if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
+ require threads::shared;
+
+ # Hack around YET ANOTHER threads::shared bug. It would
+ # occassionally forget the contents of the variable when sharing it.
+ # So we first copy the data, then share, then put our copy back.
+ *share = sub (\[$@%]) {
+ my $type = ref $_[0];
+ my $data;
+
+ if( $type eq 'HASH' ) {
+ %$data = %{$_[0]};
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @$data = @{$_[0]};
+ }
+ elsif( $type eq 'SCALAR' ) {
+ $$data = ${$_[0]};
+ }
+ else {
+ die "Unknown type: ".$type;
+ }
+
+ $_[0] = &threads::shared::share($_[0]);
+
+ if( $type eq 'HASH' ) {
+ %{$_[0]} = %$data;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ @{$_[0]} = @$data;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ ${$_[0]} = $$data;
+ }
+ else {
+ die "Unknown type: ".$type;
+ }
+
+ return $_[0];
+ };
+ }
+ # 5.8.0's threads::shared is busted when threads are off.
+ # We emulate it here.
+ else {
+ *share = sub { return $_[0] };
+ *lock = sub { 0 };
+ }
+}
+
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use Test::Builder;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(ok);
+
+ my $Test = Test::Builder->new;
+ $Test->output('my_logfile');
+
+ sub import {
+ my($self) = shift;
+ my $pack = caller;
+
+ $Test->exported_to($pack);
+ $Test->plan(@_);
+
+ $self->export_to_level(1, $self, 'ok');
+ }
+
+ sub ok {
+ my($test, $name) = @_;
+
+ $Test->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call new(), you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=cut
+
+my $Test = Test::Builder->new;
+sub new {
+ my($class) = shift;
+ $Test ||= $class->create;
+ return $Test;
+}
+
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is
+still shared amongst B<all> Test::Builder objects, even ones created using
+this method. Also, the method name may change in the future.
+
+=cut
+
+sub create {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+ $self->reset;
+
+ return $self;
+}
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=cut
+
+use vars qw($Level);
+
+sub reset {
+ my ($self) = @_;
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
+
+ $self->{Test_Died} = 0;
+ $self->{Have_Plan} = 0;
+ $self->{No_Plan} = 0;
+ $self->{Original_Pid} = $$;
+
+ share($self->{Curr_Test});
+ $self->{Curr_Test} = 0;
+ $self->{Test_Results} = &share([]);
+
+ $self->{Exported_To} = undef;
+ $self->{Expected_Tests} = 0;
+
+ $self->{Skip_All} = 0;
+
+ $self->{Use_Nums} = 1;
+
+ $self->{No_Header} = 0;
+ $self->{No_Ending} = 0;
+
+ $self->_dup_stdhandles unless $^C;
+
+ return undef;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+This is important for getting TODO tests right.
+
+=cut
+
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call plan(), don't call any of the other methods below.
+
+=cut
+
+sub plan {
+ my($self, $cmd, $arg) = @_;
+
+ return unless $cmd;
+
+ if( $self->{Have_Plan} ) {
+ die sprintf "You tried to plan twice! Second plan at %s line %d\n",
+ ($self->caller)[1,2];
+ }
+
+ if( $cmd eq 'no_plan' ) {
+ $self->no_plan;
+ }
+ elsif( $cmd eq 'skip_all' ) {
+ return $self->skip_all($arg);
+ }
+ elsif( $cmd eq 'tests' ) {
+ if( $arg ) {
+ return $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ die "Got an undefined number of tests. Looks like you tried to ".
+ "say how many tests you plan to run but made a mistake.\n";
+ }
+ elsif( !$arg ) {
+ die "You said to run 0 tests! You've got to run something.\n";
+ }
+ }
+ else {
+ require Carp;
+ my @args = grep { defined } ($cmd, $arg);
+ Carp::croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the # of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+sub expected_tests {
+ my $self = shift;
+ my($max) = @_;
+
+ if( @_ ) {
+ die "Number of tests must be a postive integer. You gave it '$max'.\n"
+ unless $max =~ /^\+?\d+$/ and $max > 0;
+
+ $self->{Expected_Tests} = $max;
+ $self->{Have_Plan} = 1;
+
+ $self->_print("1..$max\n") unless $self->no_header;
+ }
+ return $self->{Expected_Tests};
+}
+
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate # of tests.
+
+=cut
+
+sub no_plan {
+ my $self = shift;
+
+ $self->{No_Plan} = 1;
+ $self->{Have_Plan} = 1;
+}
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
+
+=cut
+
+sub has_plan {
+ my $self = shift;
+
+ return($self->{Expected_Tests}) if $self->{Expected_Tests};
+ return('no_plan') if $self->{No_Plan};
+ return(undef);
+};
+
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given $reason. Exits immediately with 0.
+
+=cut
+
+sub skip_all {
+ my($self, $reason) = @_;
+
+ my $out = "1..0";
+ $out .= " # Skip $reason" if $reason;
+ $out .= "\n";
+
+ $self->{Skip_All} = 1;
+
+ $self->_print($out) unless $self->no_header;
+ exit(0);
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in
+Test::More.
+
+$name is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if $test is true, fail if $test is false. Just
+like Test::Simple's ok().
+
+=cut
+
+sub ok {
+ my($self, $test, $name) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ unless( $self->{Have_Plan} ) {
+ require Carp;
+ Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
+ }
+
+ lock $self->{Curr_Test};
+ $self->{Curr_Test}++;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ $self->_unoverload(\$name);
+
+ $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ my($pack, $file, $line) = $self->caller;
+
+ my $todo = $self->todo($pack);
+ $self->_unoverload(\$todo);
+
+ my $out;
+ my $result = &share({});
+
+ unless( $test ) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $todo ) {
+ $out .= " # TODO $todo";
+ $result->{reason} = $todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless( $test ) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
+ $self->diag(" $msg test ($file at line $line)\n");
+ }
+
+ return $test ? 1 : 0;
+}
+
+
+sub _unoverload {
+ my $self = shift;
+
+ local($@,$!);
+
+ eval { require overload } || return;
+
+ foreach my $thing (@_) {
+ eval {
+ if( defined $$thing ) {
+ if( my $string_meth = overload::Method($$thing, '""') ) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ };
+ }
+}
+
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got eq $expected. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got == $expected. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my($self, $got, $expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, 'eq', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, 'eq', $expect, $name);
+}
+
+sub is_num {
+ my($self, $got, $expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, '==', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '==', $expect, $name);
+}
+
+sub _is_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ foreach my $val (\$got, \$expect) {
+ if( defined $$val ) {
+ if( $type eq 'eq' ) {
+ # quote and force string context
+ $$val = "'$$val'"
+ }
+ else {
+ # force numeric context
+ $$val = $$val+0;
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+ }
+
+ return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+ got: %s
+ expected: %s
+DIAGNOSTIC
+
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->is_num($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my($self, $got, $dont_expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok($test, $name);
+ $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+}
+
+sub isnt_num {
+ my($self, $got, $dont_expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok($test, $name);
+ $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '!=', $dont_expect, $name);
+}
+
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's like(). Checks if $this matches the given $regex.
+
+You'll want to avoid qr// if you want your tests to work before 5.005.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike(). Checks if $this B<does not match> the
+given $regex.
+
+=cut
+
+sub like {
+ my($self, $this, $regex, $name) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '=~', $name);
+}
+
+sub unlike {
+ my($self, $this, $regex, $name) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '!~', $name);
+}
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+
+sub maybe_regex {
+ my ($self, $regex) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my($re, $opts);
+
+ # Check for qr/foo/
+ if( ref $regex eq 'Regexp' ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+};
+
+sub _regex_ok {
+ my($self, $this, $regex, $cmp, $name) = @_;
+
+ local $Level = $Level + 1;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless (defined $usable_regex) {
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ local $^W = 0;
+ my $test = $this =~ /$usable_regex/ ? 1 : 0;
+ $test = !$test if $cmp eq '!~';
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless( $ok ) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+ $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+sub cmp_ok {
+ my($self, $got, $type, $expect, $name) = @_;
+
+ my $test;
+ {
+ local $^W = 0;
+ local($@,$!); # don't interfere with $@
+ # eval() sometimes resets $!
+ $test = eval "\$got $type \$expect";
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok($test, $name);
+
+ unless( $ok ) {
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag($got, $type, $expect);
+ }
+ else {
+ $self->_cmp_diag($got, $type, $expect);
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+ return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+ %s
+ %s
+ %s
+DIAGNOSTIC
+}
+
+=item B<BAILOUT>
+
+ $Test->BAILOUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAILOUT {
+ my($self, $reason) = @_;
+
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting $why.
+
+=cut
+
+sub skip {
+ my($self, $why) = @_;
+ $why ||= '';
+ $self->_unoverload(\$why);
+
+ unless( $self->{Have_Plan} ) {
+ require Carp;
+ Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
+ }
+
+ lock($self->{Curr_Test});
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ });
+
+ my $out = "ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # skip";
+ $out .= " $why" if length $why;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ unless( $self->{Have_Plan} ) {
+ require Carp;
+ Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
+ }
+
+ lock($self->{Curr_Test});
+ $self->{Curr_Test}++;
+
+ $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ });
+
+ my $out = "not ok";
+ $out .= " $self->{Curr_Test}" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $self->_print($out);
+
+ return 1;
+}
+
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like skip(), only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under no_plan, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test style
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should $Test look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting $Test::Builder::Level overrides. This is typically useful
+localized:
+
+ {
+ local $Test::Builder::Level = 2;
+ $Test->ok($test);
+ }
+
+=cut
+
+sub level {
+ my($self, $level) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Test::Harness will accept either, but avoid mixing the two styles.
+
+Defaults to on.
+
+=cut
+
+sub use_numbers {
+ my($self, $use_nums) = @_;
+
+ if( defined $use_nums ) {
+ $self->{Use_Nums} = $use_nums;
+ }
+ return $self->{Use_Nums};
+}
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
+
+If this is true, none of that will be done.
+
+=cut
+
+sub no_header {
+ my($self, $no_header) = @_;
+
+ if( defined $no_header ) {
+ $self->{No_Header} = $no_header;
+ }
+ return $self->{No_Header};
+}
+
+sub no_ending {
+ my($self, $no_ending) = @_;
+
+ if( defined $no_ending ) {
+ $self->{No_Ending} = $no_ending;
+ }
+ return $self->{No_Ending};
+}
+
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given @msgs. Like C<print>, arguments are simply
+appended together.
+
+Normally, it uses the failure_output() handle, but if this is for a
+TODO test, the todo_output() handle is used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because diag() is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my($self, @msgs) = @_;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape each line with a #.
+ $msg =~ s/^/# /gm;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\Z/;
+
+ local $Level = $Level + 1;
+ $self->_print_diag($msg);
+
+ return 0;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the output() filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my($self, @msgs) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ my $msg = join '', @msgs;
+
+ local($\, $", $,) = (undef, ' ', '');
+ my $fh = $self->output;
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ $msg =~ s/\n(.)/\n# $1/sg;
+
+ # Stick a newline on the end if it needs it.
+ $msg .= "\n" unless $msg =~ /\n\Z/;
+
+ print $fh $msg;
+}
+
+
+=item B<_print_diag>
+
+ $Test->_print_diag(@msg);
+
+Like _print, but prints to the current diagnostic filehandle.
+
+=cut
+
+sub _print_diag {
+ my $self = shift;
+
+ local($\, $", $,) = (undef, ' ', '');
+ my $fh = $self->todo ? $self->todo_output : $self->failure_output;
+ print $fh @_;
+}
+
+=item B<output>
+
+ $Test->output($fh);
+ $Test->output($file);
+
+Where normal "ok/not ok" test output should go.
+
+Defaults to STDOUT.
+
+=item B<failure_output>
+
+ $Test->failure_output($fh);
+ $Test->failure_output($file);
+
+Where diagnostic output on test failures and diag() should go.
+
+Defaults to STDERR.
+
+=item B<todo_output>
+
+ $Test->todo_output($fh);
+ $Test->todo_output($file);
+
+Where diagnostics about todo test failures and diag() should go.
+
+Defaults to STDOUT.
+
+=cut
+
+sub output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $self->{Out_FH} = _new_fh($fh);
+ }
+ return $self->{Out_FH};
+}
+
+sub failure_output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $self->{Fail_FH} = _new_fh($fh);
+ }
+ return $self->{Fail_FH};
+}
+
+sub todo_output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $self->{Todo_FH} = _new_fh($fh);
+ }
+ return $self->{Todo_FH};
+}
+
+
+sub _new_fh {
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( _is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ else {
+ $fh = do { local *FH };
+ open $fh, ">$file_or_fh" or
+ die "Can't open test output log $file_or_fh: $!";
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+
+sub _is_fh {
+ my $maybe_fh = shift;
+
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
+ UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
+
+ # 5.5.4's tied() and can() doesn't like getting undef
+ UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
+}
+
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+}
+
+
+sub _dup_stdhandles {
+ my $self = shift;
+
+ $self->_open_testhandles;
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush(\*TESTOUT);
+ _autoflush(\*STDOUT);
+ _autoflush(\*TESTERR);
+ _autoflush(\*STDERR);
+
+ $self->output(\*TESTOUT);
+ $self->failure_output(\*TESTERR);
+ $self->todo_output(\*TESTOUT);
+}
+
+
+my $Opened_Testhandles = 0;
+sub _open_testhandles {
+ return if $Opened_Testhandles;
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
+ open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
+ $Opened_Testhandles = 1;
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
+
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
+
+=cut
+
+sub current_test {
+ my($self, $num) = @_;
+
+ lock($self->{Curr_Test});
+ if( defined $num ) {
+ unless( $self->{Have_Plan} ) {
+ require Carp;
+ Carp::croak("Can't change the current test number without a plan!");
+ }
+
+ $self->{Curr_Test} = $num;
+
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $self->{Test_Results};
+ if( $num > @$test_results ) {
+ my $start = @$test_results ? @$test_results : 0;
+ for ($start..$num-1) {
+ $test_results->[$_] = &share({
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ });
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif( $num < @$test_results ) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ return $self->{Curr_Test};
+}
+
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my($self) = shift;
+
+ return map { $_->{'ok'} } @{ $self->{Test_Results} };
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like summary(), but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when current_test() is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+it's type is 'unkown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left undef.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since it's todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ my $self = shift;
+ return @{ $self->{Test_Results} };
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+todo() looks for a $TODO variable in your tests. If set, all tests
+will be considered 'todo' (see Test::More and Test::Harness for
+details). Returns the reason (ie. the value of $TODO) if running as
+todo tests, false otherwise.
+
+todo() is about finding the right package to look for $TODO in. It
+uses the exported_to() package to find it. If that's not set, it's
+pretty good at guessing the right package to look at based on $Level.
+
+Sometimes there is some confusion about where todo() should be looking
+for the $TODO variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my($self, $pack) = @_;
+
+ $pack = $pack || $self->exported_to || $self->caller($Level);
+ return 0 unless $pack;
+
+ no strict 'refs';
+ return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
+ : 0;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal caller(), except it reports according to your level().
+
+=cut
+
+sub caller {
+ my($self, $height) = @_;
+ $height ||= 0;
+
+ my @caller = CORE::caller($self->level + $height + 1);
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ $self->_sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ my $self = shift;
+
+ _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
+ _whoa(!$self->{Have_Plan} and $self->{Curr_Test},
+ 'Somehow your tests ran without a plan!');
+ _whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
+ 'Somehow you got a different number of results than tests ran!');
+}
+
+=item B<_whoa>
+
+ _whoa($check, $description);
+
+A sanity check, similar to assert(). If the $check is true, something
+has gone horribly wrong. It will die with the given $description and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my($check, $desc) = @_;
+ if( $check ) {
+ die <<WHOA;
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an END block. 5.005_03
+and 5.6.1 both seem to do odd things. Instead, this function edits $?
+directly. It should ONLY be called from inside an END block. It
+doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0];
+
+ return 1;
+}
+
+
+=back
+
+=end _private
+
+=cut
+
+$SIG{__DIE__} = sub {
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test->{Test_Died} = 1 unless $in_eval;
+};
+
+sub _ending {
+ my $self = shift;
+
+ $self->_sanity_check();
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ if( ($self->{Original_Pid} != $$) or
+ (!$self->{Have_Plan} && !$self->{Test_Died}) )
+ {
+ _my_exit($?);
+ return;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ my $test_results = $self->{Test_Results};
+ if( @$test_results ) {
+ # The plan? We have no plan.
+ if( $self->{No_Plan} ) {
+ $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
+ $self->{Expected_Tests} = $self->{Curr_Test};
+ }
+
+ # Auto-extended arrays and elements which aren't explicitly
+ # filled in with a shared reference will puke under 5.8.0
+ # ithreads. So we have to fill them in by hand. :(
+ my $empty_result = &share({});
+ for my $idx ( 0..$self->{Expected_Tests}-1 ) {
+ $test_results->[$idx] = $empty_result
+ unless defined $test_results->[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'},
+ @{$test_results}[0..$self->{Expected_Tests}-1];
+ $num_failed += abs($self->{Expected_Tests} - @$test_results);
+
+ if( $self->{Curr_Test} < $self->{Expected_Tests} ) {
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
+FAIL
+ }
+ elsif( $self->{Curr_Test} > $self->{Expected_Tests} ) {
+ my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+ my $s = $self->{Expected_Tests} == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
+FAIL
+ }
+ elsif ( $num_failed ) {
+ my $s = $num_failed == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed test$s of $self->{Expected_Tests}.
+FAIL
+ }
+
+ if( $self->{Test_Died} ) {
+ $self->diag(<<"FAIL");
+Looks like your test died just after $self->{Curr_Test}.
+FAIL
+
+ _my_exit( 255 ) && return;
+ }
+
+ _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
+ }
+ elsif ( $self->{Skip_All} ) {
+ _my_exit( 0 ) && return;
+ }
+ elsif ( $self->{Test_Died} ) {
+ $self->diag(<<'FAIL');
+Looks like your test died before it could output anything.
+FAIL
+ _my_exit( 255 ) && return;
+ }
+ else {
+ $self->diag("No tests run!\n");
+ _my_exit( 255 ) && return;
+ }
+}
+
+END {
+ $Test->_ending if defined $Test and !$Test->no_ending;
+}
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+
+=head1 THREADS
+
+In perl 5.8.0 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using current_test() they will all be effected.
+
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/lang/perl/BerkeleyDB/t/Test/More.pm b/lang/perl/BerkeleyDB/t/Test/More.pm
new file mode 100644
index 00000000..b0b1b1a4
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/Test/More.pm
@@ -0,0 +1,1493 @@
+package Test::More;
+
+use 5.004;
+
+use strict;
+use Test::Builder;
+
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my($file, $line) = (caller(1))[1,2];
+ warn @_, " at $file line $line\n";
+}
+
+
+
+require Exporter;
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
+$VERSION = '0.60';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+@ISA = qw(Exporter);
+@EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ can_ok isa_ok
+ diag
+ );
+
+my $Test = Test::Builder->new;
+my $Show_Diag = 1;
+
+
+# 5.004's Exporter doesn't have export_to_level.
+sub _export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => $Num_Tests;
+ # or
+ use Test::More qw(no_plan);
+ # or
+ use Test::More skip_all => $reason;
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($this eq $that, $test_name);
+
+ is ($this, $that, $test_name);
+ isnt($this, $that, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($this, qr/that/, $test_name);
+ unlike($this, qr/that/, $test_name);
+
+ cmp_ok($this, '==', $that, $test_name);
+
+ is_deeply($complex_structure1, $complex_structure2, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+ # UNIMPLEMENTED!!!
+ BAIL_OUT($why);
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+Test::Simple first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => $Num_Tests;
+
+There are rare cases when you will not know beforehand how many tests
+your script is going to run. In this case, you can declare that you
+have no plan. (Try to avoid using this as it weakens your test.)
+
+ use Test::More qw(no_plan);
+
+B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
+think everything has failed. See L<BUGS>)
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my(@plan) = @_;
+
+ my $idx = 0;
+ my @cleaned_plan;
+ while( $idx <= $#plan ) {
+ my $item = $plan[$idx];
+
+ if( $item eq 'no_diag' ) {
+ $Show_Diag = 0;
+ }
+ else {
+ push @cleaned_plan, $item;
+ }
+
+ $idx++;
+ }
+
+ $Test->plan(@cleaned_plan);
+}
+
+sub import {
+ my($class) = shift;
+
+ my $caller = caller;
+
+ $Test->exported_to($caller);
+
+ my $idx = 0;
+ my @plan;
+ my @imports;
+ while( $idx <= $#_ ) {
+ my $item = $_[$idx];
+
+ if( $item eq 'import' ) {
+ push @imports, @{$_[$idx+1]};
+ $idx++;
+ }
+ else {
+ push @plan, $item;
+ }
+
+ $idx++;
+ }
+
+ plan(@plan);
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+}
+
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($this eq $that, $test_name);
+
+This simply evaluates any expression (C<$this eq $that> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 18 (foo.t at line 42)
+
+This is actually Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my($test, $name) = @_;
+ $Test->ok($test, $name);
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $this, $that, $test_name );
+ isnt( $this, $that, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test (foo.t at line 139)
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD!
+ is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
+
+This does not check if C<exists $brooklyn{tree}> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ $Test->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ $Test->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+
+=item B<like>
+
+ like( $this, qr/that/, $test_name );
+
+Similar to ok(), like() matches $this against the regex C<qr/that/>.
+
+So this:
+
+ like($this, qr/that/, 'this is like that');
+
+is similar to:
+
+ ok( $this =~ /that/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $this, '/that/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/that/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ $Test->like(@_);
+}
+
+
+=item B<unlike>
+
+ unlike( $this, qr/that/, $test_name );
+
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike ($$;$) {
+ $Test->unlike(@_);
+}
+
+
+=item B<cmp_ok>
+
+ cmp_ok( $this, $op, $that, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $this eq $that );
+ cmp_ok( $this, 'eq', $that, 'this eq that' );
+
+ # ok( $this == $that );
+ cmp_ok( $this, '==', $that, 'this == that' );
+
+ # ok( $this && $that );
+ cmp_ok( $this, '&&', $that, 'this && that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $this
+and $that were:
+
+ not ok 1
+ # Failed test (foo.t at line 12)
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+ $Test->cmp_ok(@_);
+}
+
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my($proto, @methods) = @_;
+ my $class = ref $proto || $proto;
+
+ unless( @methods ) {
+ my $ok = $Test->ok( 0, "$class->can(...)" );
+ $Test->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ local($!, $@); # don't interfere with caller's $@
+ # eval sometimes resets $!
+ eval { $proto->can($method) } || push @nok, $method;
+ }
+
+ my $name;
+ $name = @methods == 1 ? "$class->can('$methods[0]')"
+ : "$class->can(...)";
+
+ my $ok = $Test->ok( !@nok, $name );
+
+ $Test->diag(map " $class->can('$_') failed\n", @nok);
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given C<< $object->isa($class) >>. Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my($object, $class, $obj_name) = @_;
+
+ my $diag;
+ $obj_name = 'The object' unless defined $obj_name;
+ my $name = "$obj_name isa $class";
+ if( !defined $object ) {
+ $diag = "$obj_name isn't defined";
+ }
+ elsif( !ref $object ) {
+ $diag = "$obj_name isn't a reference";
+ }
+ else {
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ local($@, $!); # eval sometimes resets $!
+ my $rslt = eval { $object->isa($class) };
+ if( $@ ) {
+ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+ if( !UNIVERSAL::isa($object, $class) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ } else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen. Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+ }
+ }
+ elsif( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+
+
+
+ my $ok;
+ if( $diag ) {
+ $ok = $Test->ok( 0, $name );
+ $Test->diag(" $diag\n");
+ }
+ else {
+ $ok = $Test->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ $Test->ok(1, @_);
+}
+
+sub fail (;$) {
+ $Test->ok(0, @_);
+}
+
+=back
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Like C<print> @diagnostic_message is simply concatinated
+together.
+
+Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test (foo.t at line 52)
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+All diag()s can be made silent by passing the "no_diag" option to
+Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful
+if you have diagnostics for personal testing but then wish to make
+them silent for release without commenting out each individual
+statement.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ return unless $Show_Diag;
+ $Test->diag(@_);
+}
+
+
+=back
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+Version numbers can be checked like so:
+
+ # Just like "use Some::Module 1.02"
+ BEGIN { use_ok('Some::Module', 1.02) }
+
+Don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+because the notion of "compile-time" is relative. Instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my($module, @imports) = @_;
+ @imports = () unless @imports;
+
+ my($pack,$filename,$line) = caller;
+
+ local($@,$!); # eval sometimes interferes with $!
+
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ eval <<USE;
+package $pack;
+use $module $imports[0];
+USE
+ }
+ else {
+ eval <<USE;
+package $pack;
+use $module \@imports;
+USE
+ }
+
+ my $ok = $Test->ok( !$@, "use $module;" );
+
+ unless( $ok ) {
+ chomp $@;
+ $@ =~ s{^BEGIN failed--compilation aborted at .*$}
+ {BEGIN failed--compilation aborted at $filename line $line.}m;
+ $Test->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+ require_ok($file);
+
+Like use_ok(), except it requires the $module or $file.
+
+=cut
+
+sub require_ok ($) {
+ my($module) = shift;
+
+ my $pack = caller;
+
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ local($!, $@); # eval sometimes interferes with $!
+ eval <<REQUIRE;
+package $pack;
+require $module;
+REQUIRE
+
+ my $ok = $Test->ok( !$@, "require $module;" );
+
+ unless( $ok ) {
+ chomp $@;
+ $Test->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+ $module =~ /^[a-zA-Z]\w*$/;
+}
+
+=back
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+#'#
+sub skip {
+ my($why, $how_many) = @_;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $Test->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->skip($why);
+ }
+
+ local $^W = 0;
+ last SKIP;
+}
+
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+B<NOTE>: TODO tests require a Test::Harness upgrade else it will
+treat it as a normal failure. See L<BUGS>)
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my($why, $how_many) = @_;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $Test->has_plan eq 'no_plan';
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->todo_skip($why);
+ }
+
+ local $^W = 0;
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+=head2 Complex data structures
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two data structures are equivalent. For these
+instances Test::More provides a handful of useful functions.
+
+B<NOTE> I'm not quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $this, $that, $test_name );
+
+Similar to is(), except that if $this and $that are hash or array
+references, it does a deep comparison walking each data structure to
+see if they are equivalent. If the two structures are different, it
+will display the place where they start differing.
+
+Test::Differences and Test::Deep provide more in-depth functionality
+along these lines.
+
+=back
+
+=cut
+
+use vars qw(@Data_Stack %Refs_Seen);
+my $DNE = bless [], 'Does::Not::Exist';
+sub is_deeply {
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<WARNING;
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ _carp sprintf $msg, scalar @_;
+
+ return $Test->ok(0);
+ }
+
+ my($this, $that, $name) = @_;
+
+ my $ok;
+ if( !ref $this and !ref $that ) { # neither is a reference
+ $ok = $Test->is_eq($this, $that, $name);
+ }
+ elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
+ $ok = $Test->ok(0, $name);
+ $Test->diag( _format_stack({ vals => [ $this, $that ] }) );
+ }
+ else { # both references
+ local @Data_Stack = ();
+ if( _deep_check($this, $that) ) {
+ $ok = $Test->ok(1, $name);
+ }
+ else {
+ $ok = $Test->ok(0, $name);
+ $Test->diag(_format_stack(@Data_Stack));
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{$Stack[-1]{vals}}[0,1];
+ my @vars = ();
+ ($vars[0] = $var) =~ s/\$FOO/ \$got/;
+ ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx (0..$#vals) {
+ my $val = $vals[$idx];
+ $vals[$idx] = !defined $val ? 'undef' :
+ $val eq $DNE ? "Does not exist" :
+ ref $val ? "$val" :
+ "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) {
+ return $type if UNIVERSAL::isa($thing, $type);
+ }
+
+ return '';
+}
+
+
+=head2 Discouraged comparison functions
+
+The use of the following functions is discouraged as they are not
+actually testing functions and produce no diagnostics to help figure
+out what went wrong. They were written before is_deeply() existed
+because I couldn't figure out how to display a useful diff of two
+arbitrary data structures.
+
+These functions are usually used inside an ok().
+
+ ok( eq_array(\@this, \@that) );
+
+C<is_deeply()> can do that better and with diagnostics.
+
+ is_deeply( \@this, \@that );
+
+They may be deprecated in future versions.
+
+=over 4
+
+=item B<eq_array>
+
+ my $is_eq = eq_array(\@this, \@that);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ local @Data_Stack;
+ _deep_check(@_);
+}
+
+sub _eq_array {
+ my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for (0..$max) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
+ $ok = _deep_check($e1,$e2);
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _deep_check {
+ my($e1, $e2) = @_;
+ my $ok = 0;
+
+ # Effectively turn %Refs_Seen into a stack. This avoids picking up
+ # the same referenced used twice (such as [\$a, \$a]) to be considered
+ # circular.
+ local %Refs_Seen = %Refs_Seen;
+
+ {
+ # Quiet uninitialized value warnings when comparing undefs.
+ local $^W = 0;
+
+ $Test->_unoverload(\$e1, \$e2);
+
+ # Either they're both references or both not.
+ my $same_ref = !(!ref $e1 xor !ref $e2);
+ my $not_ref = (!ref $e1 and !ref $e2);
+
+ if( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif ( $e1 == $DNE xor $e2 == $DNE ) {
+ $ok = 0;
+ }
+ elsif ( $same_ref and ($e1 eq $e2) ) {
+ $ok = 1;
+ }
+ elsif ( $not_ref ) {
+ push @Data_Stack, { type => '', vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ else {
+ if( $Refs_Seen{$e1} ) {
+ return $Refs_Seen{$e1} eq $e2;
+ }
+ else {
+ $Refs_Seen{$e1} = "$e2";
+ }
+
+ my $type = _type($e1);
+ $type = 'DIFFERENT' unless _type($e2) eq $type;
+
+ if( $type eq 'DIFFERENT' ) {
+ push @Data_Stack, { type => $type, vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array($e1, $e2);
+ }
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash($e1, $e2);
+ }
+ elsif( $type eq 'REF' ) {
+ push @Data_Stack, { type => $type, vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ elsif( $type eq 'SCALAR' ) {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ else {
+ _whoa(1, "No type in _deep_check");
+ }
+ }
+ }
+
+ return $ok;
+}
+
+
+sub _whoa {
+ my($check, $desc) = @_;
+ if( $check ) {
+ die <<WHOA;
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+
+=item B<eq_hash>
+
+ my $is_eq = eq_hash(\%this, \%that);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ local @Data_Stack;
+ return _deep_check(@_);
+}
+
+sub _eq_hash {
+ my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k (keys %$bigger) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
+ $ok = _deep_check($e1, $e2);
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ my $is_eq = eq_set(\@this, \@that);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+ ok( eq_set(\@this, \@that) );
+
+Is better written:
+
+ is_deeply( [sort @this], [sort @that] );
+
+B<NOTE> By historical accident, this is not a true set comparision.
+While the order of elements does not matter, duplicate elements do.
+
+Test::Deep contains much better set comparison functions.
+
+=cut
+
+sub eq_set {
+ my($a1, $a2) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ # There's faster ways to do this, but this is easiest.
+ local $^W = 0;
+
+ # We must make sure that references are treated neutrally. It really
+ # doesn't matter how we sort them, as long as both arrays are sorted
+ # with the same algorithm.
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ return eq_array(
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1],
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2]
+ );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+=back
+
+
+=head1 EXIT CODES
+
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
+
+So the exit codes are...
+
+ 0 all tests successful
+ 255 test died
+ any other number how many failed (including missing or extras)
+
+If you fail more than 254 tests, it will be reported as 254.
+
+B<NOTE> This behavior may go away in future versions.
+
+
+=head1 CAVEATS and NOTES
+
+=over 4
+
+=item Backwards compatibility
+
+Test::More works with Perls as old as 5.004_05.
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings>. This prevents
+Test::More from piercing an object's interface allowing better blackbox
+testing. So if a function starts returning overloaded objects instead of
+bare strings your tests won't notice the difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest Test::Deep which contains more flexible testing functions for
+complex data structures.
+
+
+=item Threads
+
+Test::More will only be aware of threads if "use threads" has been done
+I<before> Test::More is loaded. This is ok:
+
+ use threads;
+ use Test::More;
+
+This may cause problems:
+
+ use Test::More
+ use threads;
+
+
+=item Test::Harness upgrade
+
+no_plan and todo depend on new Test::Harness features and fixes. If
+you're going to distribute tests that use no_plan or todo your
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
+
+Installing Test::More should also upgrade Test::Harness.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test> is the old testing module. Its main benefit is that it has
+been distributed with Perl since 5.004_05.
+
+L<Test::Harness> for details on how your test results are interpreted
+by Perl.
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test::Class> is like XUnit but more perlish.
+
+L<Test::Deep> gives you more powerful complex data structure testing.
+
+L<Test::Unit> is XUnit style testing.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<Bundle::Test> installs a whole bunch of useful test modules.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/lang/perl/BerkeleyDB/t/btree.t b/lang/perl/BerkeleyDB/t/btree.t
new file mode 100644
index 00000000..44667a56
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/btree.t
@@ -0,0 +1,936 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't';
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+plan tests => 250;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/
+ or print "# $@" ;
+
+ eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ;
+ ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Btree
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ is $db->Env, undef;
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->status() == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_put("key", "value") == 0 ;
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+ ok $db->db_del("some key") == 0 ;
+ ok $db->db_get("some key", $value) == DB_NOTFOUND ;
+ ok $db->status() == DB_NOTFOUND ;
+ ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
+ or diag "Status is [" . $db->status() . "]";
+
+ ok $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEXIST'} ;
+ ok $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+
+ # test DB_GET_BOTH
+ my ($k, $v) = ("key", "value") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("key", "fred") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("another", "value") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+
+}
+
+{
+ # Check simple env works with a hash.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+ @StdErrFile, -Home => $home ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ isa_ok $db->Env, 'BerkeleyDB::Env';
+ $db->Env->errPrefix("abc");
+ is $db->Env->errPrefix("abc"), 'abc';
+ # Add a k/v pair
+ my $value ;
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ #print "[$db] [$!] $BerkeleyDB::Error\n" ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # create the cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ $k = $v = "" ;
+ my %copy = %data ;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'};
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $status == DB_NOTFOUND ;
+ ok $status =~ $DB_errors{'DB_NOTFOUND'};
+ ok $cursor->status() == $status ;
+ ok $cursor->status() eq $status ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ ($k, $v) = ("green", "house") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("green", "door") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("black", "house") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+}
+
+{
+ # Tied Hash interface
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ is((tied %hash)->Env, undef);
+ # check "each" with an empty database
+ my $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ ++ $count ;
+ }
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok $count == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $hash{"some key"} = "some value";
+ ok ((tied %hash)->status() == 0) ;
+ ok $hash{"some key"} eq "some value";
+ ok defined $hash{"some key"} ;
+ ok ((tied %hash)->status() == 0) ;
+ ok exists $hash{"some key"} ;
+ ok !defined $hash{"jimmy"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok !exists $hash{"jimmy"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+
+ delete $hash{"some key"} ;
+ ok ((tied %hash)->status() == 0) ;
+ ok ! defined $hash{"some key"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok ! exists $hash{"some key"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+
+ $hash{1} = 2 ;
+ $hash{10} = 20 ;
+ $hash{1000} = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ ok $keys == 1011 ;
+ ok $values == 2022 ;
+
+ # now clear the hash
+ %hash = () ;
+ ok keys %hash == 0 ;
+
+ untie %hash ;
+}
+
+{
+ # override default compare
+ my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
+ my $value ;
+ my (%h, %g, %k) ;
+ my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
+ ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -Flags => DB_CREATE ;
+
+ ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -Flags => DB_CREATE ;
+
+ ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
+ -Compare => sub { length $_[0] <=> length $_[1] },
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+ my @srt_3 = sort { length $a <=> length $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ $h{$_} = 1 ;
+ $g{$_} = 1 ;
+ $k{$_} = 1 ;
+ }
+
+ sub ArrayCompare
+ {
+ my($a, $b) = @_ ;
+
+ return 0 if @$a != @$b ;
+
+ foreach (1 .. length @$a)
+ {
+ return 0 unless $$a[$_] eq $$b[$_] ;
+ }
+
+ 1 ;
+ }
+
+ ok ArrayCompare (\@srt_1, [keys %h]);
+ ok ArrayCompare (\@srt_2, [keys %g]);
+ ok ArrayCompare (\@srt_3, [keys %k]);
+
+}
+
+{
+ # override default compare, with duplicates, don't sort values
+ my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
+ my $value ;
+ my (%h, %g, %k) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ;
+ my @Values = qw( 1 0 3 dd x abc 0 ) ;
+ ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
+ -Compare => sub { length $_[0] <=> length $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+ my @srt_3 = sort { length $a <=> length $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ $k{$_} = $value ;
+ }
+
+ sub getValues
+ {
+ my $hash = shift ;
+ my $db = tied %$hash ;
+ my $cursor = $db->db_cursor() ;
+ my @values = () ;
+ my ($k, $v) = (0,0) ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ push @values, $v ;
+ }
+ return @values ;
+ }
+
+ ok ArrayCompare (\@srt_1, [keys %h]);
+ ok ArrayCompare (\@srt_2, [keys %g]);
+ ok ArrayCompare (\@srt_3, [keys %k]);
+ ok ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]);
+ ok ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]);
+ ok ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]);
+
+ # test DB_DUP_NEXT
+ ok my $cur = (tied %g)->db_cursor() ;
+ my ($k, $v) = (9, "") ;
+ ok $cur->c_get($k, $v, DB_SET) == 0 ;
+ ok $k == 9 && $v == 0 ;
+ ok $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok $k == 9 && $v eq "x" ;
+ ok $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
+}
+
+{
+ # override default compare, with duplicates, sort values
+ my $lex = new LexFile $Dfile, $Dfile2;
+ my $value ;
+ my (%h, %g) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
+ my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
+ ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -Compare => sub { $_[0] <=> $_[1] },
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
+ -Compare => sub { $_[0] cmp $_[1] },
+ -DupCompare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP,
+
+
+
+ -Flags => DB_CREATE ;
+
+ my @srt_1 ;
+ { local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+ }
+ my @srt_2 = sort { $a cmp $b } @Keys ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ }
+
+ ok ArrayCompare (\@srt_1, [keys %h]);
+ ok ArrayCompare (\@srt_2, [keys %g]);
+ ok ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]);
+ ok ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]);
+
+}
+
+{
+ # get_dup etc
+ my $lex = new LexFile $Dfile;
+ my %hh ;
+
+ ok my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $hh{'Smith'} = 'John' ;
+ $hh{'mouse'} = 'mickey' ;
+
+ # first work in scalar context
+ ok scalar $YY->get_dup('Unknown') == 0 ;
+ ok scalar $YY->get_dup('Smith') == 1 ;
+ ok scalar $YY->get_dup('Wall') == 3 ;
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ ok "@unknown" eq "" ;
+
+ my @smith = $YY->get_dup('Smith') ;
+ ok "@smith" eq "John" ;
+
+ {
+ my @wall = $YY->get_dup('Wall') ;
+ my %wall ;
+ @wall{@wall} = @wall ;
+ ok (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
+ }
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ ok keys %unknown == 0 ;
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ ok keys %smith == 1 && $smith{'John'} ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 1 ;
+
+ undef $YY ;
+ untie %hh ;
+
+}
+
+{
+ # in-memory file
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $fd ;
+ my $value ;
+ ok my $db = tie %hash, 'BerkeleyDB::Btree' ;
+
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok ! $pon && $off == 0 && $len == 0 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "bo" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "ho" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "t" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "se" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 3 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "boat" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "house" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $db->db_put("red", "") == 0 ;
+ ok $db->db_put("green", "AB") == 0 ;
+ ok $db->db_put("blue", "XYZ") == 0 ;
+ ok $db->db_put("new", "KLM") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "at" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
+ ok $db->db_get("new", $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok ! $pon ;
+ ok $off == 0 ;
+ ok $len == 0 ;
+ ok $db->db_put("red", "PPP") == 0 ;
+ ok $db->db_put("green", "Q") == 0 ;
+ ok $db->db_put("blue", "XYZ") == 0 ;
+ ok $db->db_put("new", "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
+ ok $db->db_get("new", $value) == 0 && $value eq "KLMTU" ;
+}
+
+{
+ # partial
+ # check works via tied hash
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ while (my ($k, $v) = each %data) {
+ $hash{$k} = $v ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok $hash{"red"} eq "bo" ;
+ ok $hash{"green"} eq "ho" ;
+ ok $hash{"blue"} eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok $hash{"red"} eq "t" ;
+ ok $hash{"green"} eq "se" ;
+ ok $hash{"blue"} eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "boat" ;
+ ok $hash{"green"} eq "house" ;
+ ok $hash{"blue"} eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $hash{"red"} = "" ;
+ ok $hash{"green"} = "AB" ;
+ ok $hash{"blue"} = "XYZ" ;
+ ok $hash{"new"} = "KLM" ;
+
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "at" ;
+ ok $hash{"green"} eq "ABuse" ;
+ ok $hash{"blue"} eq "XYZa" ;
+ ok $hash{"new"} eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok $hash{"red"} = "PPP" ;
+ ok $hash{"green"} = "Q" ;
+ ok $hash{"blue"} = "XYZ" ;
+ ok $hash{"new"} = "TU" ;
+
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "at\0PPP" ;
+ ok $hash{"green"} eq "ABuQ" ;
+ ok $hash{"blue"} eq "XYZXYZ" ;
+ ok $hash{"new"} eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ isa_ok((tied %hash)->Env, 'BerkeleyDB::Env');
+ (tied %hash)->Env->errPrefix("abc");
+ is((tied %hash)->Env->errPrefix("abc"), 'abc');
+ ok ((my $Z = $txn->txn_commit()) == 0) ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ #ok $txn->txn_abort() == 0 ;
+ ok (($Z = $txn->txn_abort()) == 0) ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # DB_DUP
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ ok keys %hash == 6 ;
+
+ # create a cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ my $key = "Wall" ;
+ my $value ;
+ ok $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok $key eq "Wall" && $value eq "Larry" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Stone" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Brick" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Brick" ;
+
+ #my $ref = $db->db_stat() ;
+ #ok ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
+#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
+
+ undef $db ;
+ undef $cursor ;
+ untie %hash ;
+
+}
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Minkey =>3 ,
+ -Pagesize => 2 **12
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 0;
+ ok $ref->{'bt_minkey'} == 3;
+ ok $ref->{'bt_pagesize'} == 2 ** 12;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 3;
+}
+
+{
+ # 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 BerkeleyDB;
+ @ISA=qw(BerkeleyDB BerkeleyDB::Btree );
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_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 ;
+
+ use Test::More;
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ ok $@ eq "" ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ ok $@ eq "" && $X ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ ok $@ eq "" ;
+ ok $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
+ ok $@ eq "" ;
+ ok $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ ok $@ eq "" ;
+ ok $ret == 1 ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ ok $@ eq "" ;
+ ok $ret eq "[[10]]" ;
+
+ undef $X;
+ untie %h;
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+{
+ # DB_RECNUM, DB_SET_RECNO & DB_GET_RECNO
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) = ("", "");
+ ok my $db = new BerkeleyDB::Btree
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Property => DB_RECNUM ;
+
+
+ # create some data
+ my @data = (
+ "A zero",
+ "B one",
+ "C two",
+ "D three",
+ "E four"
+ ) ;
+
+ my $ix = 0 ;
+ my $ret = 0 ;
+ foreach (@data) {
+ $ret += $db->db_put($_, $ix) ;
+ ++ $ix ;
+ }
+ ok $ret == 0 ;
+
+ # db_get & DB_SET_RECNO
+ $k = 1 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "B one" && $v == 1 ;
+
+ $k = 3 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "D three" && $v == 3 ;
+
+ $k = 4 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "E four" && $v == 4 ;
+
+ $k = 0 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "A zero" && $v == 0 ;
+
+ # cursor & DB_SET_RECNO
+
+ # create the cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ $k = 2 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "C two" && $v == 2 ;
+
+ $k = 0 ;
+ ok $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "A zero" && $v == 0 ;
+
+ $k = 3 ;
+ ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
+ ok $k eq "D three" && $v == 3 ;
+
+ # cursor & DB_GET_RECNO
+ ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok $k eq "A zero" && $v == 0 ;
+ ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok $v == 0 ;
+
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k eq "B one" && $v == 1 ;
+ ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok $v == 1 ;
+
+ ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok $k eq "E four" && $v == 4 ;
+ ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
+ ok $v == 4 ;
+
+}
+
diff --git a/lang/perl/BerkeleyDB/t/cds.t b/lang/perl/BerkeleyDB/t/cds.t
new file mode 100644
index 00000000..2cea90a4
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/cds.t
@@ -0,0 +1,73 @@
+#!./perl -w
+
+# Tests for Concurrent Data Store mode
+
+use strict ;
+use lib 't' ;
+
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 2.x or better" )
+ if $BerkeleyDB::db_version < 2;
+
+ plan tests => 12;
+}
+
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+{
+ # Error case -- env not opened in CDS mode
+
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home, @StdErrFile ;
+
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ ok ! $env->cds_enabled() ;
+ ok ! $db->cds_enabled() ;
+
+ eval { $db->cds_lock() };
+ ok $@ =~ /CDS not enabled for this database/;
+
+ undef $db;
+ undef $env ;
+}
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_INIT_CDB|DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home, @StdErrFile ;
+
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ ok $env->cds_enabled() ;
+ ok $db->cds_enabled() ;
+
+ my $cds = $db->cds_lock() ;
+ ok $cds ;
+
+ undef $db;
+ undef $env ;
+}
diff --git a/lang/perl/BerkeleyDB/t/db-3.0.t b/lang/perl/BerkeleyDB/t/db-3.0.t
new file mode 100644
index 00000000..eb8f18aa
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-3.0.t
@@ -0,0 +1,85 @@
+#!./perl -w
+
+# ID: 1.2, 7/17/97
+
+use strict ;
+
+use lib 't';
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 3.x or better" )
+ if $BerkeleyDB::db_version < 3;
+
+ plan tests => 14;
+}
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ # set_mutexlocks
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ chdir "./fred" ;
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE, @StdErrFile ;
+ ok $env->set_mutexlocks(0) == 0 ;
+ chdir ".." ;
+ undef $env ;
+}
+
+{
+ # c_dup
+
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "green" => "house",
+ "red" => 2,
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (@data)
+ {
+ my $k = shift @data ;
+ my $v = shift @data ;
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # create a cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ # point to a specific k/v pair
+ $k = "green" ;
+ ok $cursor->c_get($k, $v, DB_SET) == 0 ;
+ ok $v eq "house" ;
+
+ # duplicate the cursor
+ my $dup_cursor = $cursor->c_dup(DB_POSITION);
+ ok $dup_cursor ;
+
+ # move original cursor off green/house
+ my $s = $cursor->c_get($k, $v, DB_NEXT) ;
+ ok $k ne "green" ;
+ ok $v ne "house" ;
+
+ # duplicate cursor should still be on green/house
+ ok $dup_cursor->c_get($k, $v, DB_CURRENT) == 0;
+ ok $k eq "green" ;
+ ok $v eq "house" ;
+
+}
+
diff --git a/lang/perl/BerkeleyDB/t/db-3.1.t b/lang/perl/BerkeleyDB/t/db-3.1.t
new file mode 100644
index 00000000..3950fe57
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-3.1.t
@@ -0,0 +1,242 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't';
+use util ;
+
+use Test::More ;
+
+use BerkeleyDB;
+
+plan(skip_all => "1..0 # Skip: this needs Berkeley DB 3.1.x or better\n")
+ if $BerkeleyDB::db_version < 3.1 ;
+
+plan(tests => 48) ;
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+
+{
+ title "c_count";
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+ ok $db, " open database ok";
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ is keys %hash, 6, " keys == 6" ;
+
+ # create a cursor
+ my $cursor = $db->db_cursor() ;
+ ok $cursor, " created cursor";
+
+ my $key = "Wall" ;
+ my $value ;
+ cmp_ok $cursor->c_get($key, $value, DB_SET), '==', 0, " c_get ok" ;
+ is $key, "Wall", " key is 'Wall'";
+ is $value, "Larry", " value is 'Larry'"; ;
+
+ my $count ;
+ cmp_ok $cursor->c_count($count), '==', 0, " c_count ok" ;
+ is $count, 4, " count is 4" ;
+
+ $key = "Smith" ;
+ cmp_ok $cursor->c_get($key, $value, DB_SET), '==', 0, " c_get ok" ;
+ is $key, "Smith", " key is 'Smith'";
+ is $value, "John", " value is 'John'"; ;
+
+ cmp_ok $cursor->c_count($count), '==', 0, " c_count ok" ;
+ is $count, 1, " count is 1" ;
+
+
+ undef $db ;
+ undef $cursor ;
+ untie %hash ;
+
+}
+
+{
+ title "db_key_range";
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+ isa_ok $db, 'BerkeleyDB::Btree', " create database ok";
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ is keys %hash, 6, " 6 keys" ;
+
+ my $key = "Wall" ;
+ my ($less, $equal, $greater) ;
+ cmp_ok $db->db_key_range($key, $less, $equal, $greater), '==', 0, " db_key_range ok" ;
+
+ cmp_ok $less, '!=', 0 ;
+ cmp_ok $equal, '!=', 0 ;
+ cmp_ok $greater, '!=', 0 ;
+
+ $key = "Smith" ;
+ cmp_ok $db->db_key_range($key, $less, $equal, $greater), '==', 0, " db_key_range ok" ;
+
+ cmp_ok $less, '==', 0 ;
+ cmp_ok $equal, '!=', 0 ;
+ cmp_ok $greater, '!=', 0 ;
+
+ $key = "NotThere" ;
+ cmp_ok $db->db_key_range($key, $less, $equal, $greater), '==', 0, " db_key_range ok" ;
+
+ cmp_ok $less, '==', 0 ;
+ cmp_ok $equal, '==', 0 ;
+ cmp_ok $greater, '==', 1 ;
+
+ undef $db ;
+ untie %hash ;
+
+}
+
+{
+ title "rename a subdb";
+
+ my $lex = new LexFile $Dfile ;
+
+ my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+ isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";
+
+ my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Subname => "joe" ,
+ -Flags => DB_CREATE ;
+ isa_ok $db2, 'BerkeleyDB::Btree', " create database ok";
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db1, %data), " added to db1 ok" ;
+ ok addData($db2, %data), " added to db2 ok" ;
+
+ undef $db1 ;
+ undef $db2 ;
+
+ # now rename
+ cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile,
+ -Subname => "fred",
+ -Newname => "harry"), '==', 0, " rename ok";
+
+ my $db3 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "harry" ;
+ isa_ok $db3, 'BerkeleyDB::Hash', " verify rename";
+
+}
+
+{
+ title "rename a file";
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+
+ my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE;
+ isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";
+
+ my $db2 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "joe" ,
+ -Flags => DB_CREATE ;
+ isa_ok $db2, 'BerkeleyDB::Hash', " create database ok";
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db1, %data), " add data to db1" ;
+ ok addData($db2, %data), " add data to db2" ;
+
+ undef $db1 ;
+ undef $db2 ;
+
+ # now rename
+ cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile, -Newname => $Dfile2),
+ '==', 0, " rename file to $Dfile2 ok";
+
+ my $db3 = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Subname => "fred" ;
+ isa_ok $db3, 'BerkeleyDB::Hash', " verify rename"
+ or diag "$! $BerkeleyDB::Error";
+
+
+# TODO add rename with no subname & txn
+}
+
+{
+ title "verify";
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+
+ my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+ isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db1, %data), " added data ok" ;
+
+ undef $db1 ;
+
+ # now verify
+ cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
+ -Subname => "fred",
+ ), '==', 0, " verify ok";
+
+ # now verify & dump
+ cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
+ -Subname => "fred",
+ -Outfile => $Dfile2,
+ ), '==', 0, " verify and dump ok";
+
+}
+
+# db_remove with env
+
diff --git a/lang/perl/BerkeleyDB/t/db-3.2.t b/lang/perl/BerkeleyDB/t/db-3.2.t
new file mode 100644
index 00000000..54c28072
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-3.2.t
@@ -0,0 +1,57 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 3.2.x or better" )
+ if $BerkeleyDB::db_version < 3.2;
+
+ plan tests => 6;
+}
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+
+{
+ # set_q_extentsize
+
+ ok 1 ;
+}
+
+{
+ # env->set_flags
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE ,
+ -SetFlags => DB_NOMMAP ;
+
+ undef $env ;
+}
+
+{
+ # env->set_flags
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE ;
+ ok ! $env->set_flags(DB_NOMMAP, 1);
+
+ undef $env ;
+}
diff --git a/lang/perl/BerkeleyDB/t/db-3.3.t b/lang/perl/BerkeleyDB/t/db-3.3.t
new file mode 100644
index 00000000..4539a8c8
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-3.3.t
@@ -0,0 +1,476 @@
+#!./perl -w
+
+
+use strict ;
+
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 3.3.x or better" )
+ if $BerkeleyDB::db_version < 3.3;
+
+ plan tests => 130;
+}
+
+umask(0);
+
+{
+ # db->truncate
+
+ my $Dfile;
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ is countRecords($db), 3 ;
+
+ # now truncate the database
+ my $count = 0;
+ ok $db->truncate($count) == 0 ;
+
+ is $count, 3 ;
+ ok countRecords($db) == 0 ;
+
+}
+
+{
+ # db->associate -- secondary keys
+
+ sub sec_key
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($secondary), 3 ;
+
+ ok $secondary->db_get("house", $v) == 0;
+ is $v, "house";
+
+ ok $secondary->db_get("sea", $v) == 0;
+ is $v, "sea";
+
+ ok $secondary->db_get("flag", $v) == 0;
+ is $v, "flag";
+
+ # pget to primary database is illegal
+ ok $primary->db_pget('red', $pk, $v) != 0 ;
+
+ # pget to secondary database is ok
+ ok $secondary->db_pget('house', $pk, $v) == 0 ;
+ is $pk, 'green';
+ is $v, 'house';
+
+ ok my $p_cursor = $primary->db_cursor();
+ ok my $s_cursor = $secondary->db_cursor();
+
+ # c_get from primary
+ $k = 'green';
+ ok $p_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 'green';
+ is $v, 'house';
+
+ # c_get from secondary
+ $k = 'sea';
+ ok $s_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 'sea';
+ is $v, 'sea';
+
+ # c_pget from primary database should fail
+ $k = 1;
+ ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
+
+ # c_pget from secondary database
+ $k = 'flag';
+ ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
+ or diag "$BerkeleyDB::Error\n";
+ is $k, 'flag';
+ is $pk, 'red';
+ is $v, 'flag';
+
+ # check put to secondary is illegal
+ ok $secondary->db_put("tom", "dick") != 0;
+ is countRecords($secondary), 3 ;
+
+ # delete from primary
+ ok $primary->db_del("green") == 0 ;
+ is countRecords($primary), 2 ;
+
+ # check has been deleted in secondary
+ ok $secondary->db_get("house", $v) != 0;
+ is countRecords($secondary), 2 ;
+
+ # delete from secondary
+ ok $secondary->db_del('flag') == 0 ;
+ is countRecords($secondary), 1 ;
+
+
+ # check deleted from primary
+ ok $primary->db_get("red", $v) != 0;
+ is countRecords($primary), 1 ;
+
+}
+
+
+ # db->associate -- multiple secondary keys
+
+
+ # db->associate -- same again but when DB_DUP is specified.
+
+
+{
+ # db->associate -- secondary keys, each with a user defined sort
+
+ sub sec_key2
+ {
+ my $pkey = shift ;
+ my $pdata = shift ;
+ #print "in sec_key2 [$pkey][$pdata]\n";
+
+ $_[0] = length $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
+ -Compare => sub { return $_[0] cmp $_[1]},
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Btree -Filename => $Dfile2,
+ -Compare => sub { return $_[0] <=> $_[1]},
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key2) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "orange"=> "custard",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put [$r] $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+ #print "ret $ret\n";
+
+ #print "Primary\n" ; dumpdb($primary) ;
+ #print "Secondary\n" ; dumpdb($secondary) ;
+
+ # check the records in the secondary
+ is countRecords($secondary), 4 ;
+
+ my $p_data = joinkeys($primary, " ");
+ #print "primary [$p_data]\n" ;
+ is $p_data, join " ", sort { $a cmp $b } keys %data ;
+ my $s_data = joinkeys($secondary, " ");
+ #print "secondary [$s_data]\n" ;
+ is $s_data, join " ", sort { $a <=> $b } map { length } values %data ;
+
+}
+
+{
+ # db->associate -- primary recno, secondary hash
+
+ sub sec_key3
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Recno -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key3) == 0;
+
+ # add data to the primary
+ my %data = (
+ 0 => "flag",
+ 1 => "house",
+ 2 => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($secondary), 3 ;
+
+ ok $secondary->db_get("flag", $v) == 0;
+ is $v, "flag";
+
+ ok $secondary->db_get("house", $v) == 0;
+ is $v, "house";
+
+ ok $secondary->db_get("sea", $v) == 0;
+ is $v, "sea" ;
+
+ # pget to primary database is illegal
+ ok $primary->db_pget(0, $pk, $v) != 0 ;
+
+ # pget to secondary database is ok
+ ok $secondary->db_pget('house', $pk, $v) == 0 ;
+ is $pk, 1 ;
+ is $v, 'house';
+
+ ok my $p_cursor = $primary->db_cursor();
+ ok my $s_cursor = $secondary->db_cursor();
+
+ # c_get from primary
+ $k = 1;
+ ok $p_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 1;
+ is $v, 'house';
+
+ # c_get from secondary
+ $k = 'sea';
+ ok $s_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 'sea'
+ or warn "# key [$k]\n";
+ is $v, 'sea';
+
+ # c_pget from primary database should fail
+ $k = 1;
+ ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
+
+ # c_pget from secondary database
+ $k = 'sea';
+ ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
+ is $k, 'sea' ;
+ is $pk, 2 ;
+ is $v, 'sea';
+
+ # check put to secondary is illegal
+ ok $secondary->db_put("tom", "dick") != 0;
+ is countRecords($secondary), 3 ;
+
+ # delete from primary
+ ok $primary->db_del(2) == 0 ;
+ is countRecords($primary), 2 ;
+
+ # check has been deleted in secondary
+ ok $secondary->db_get("sea", $v) != 0;
+ is countRecords($secondary), 2 ;
+
+ # delete from secondary
+ ok $secondary->db_del('flag') == 0 ;
+ is countRecords($secondary), 1 ;
+
+
+ # check deleted from primary
+ ok $primary->db_get(0, $v) != 0;
+ is countRecords($primary), 1 ;
+
+}
+
+{
+ # db->associate -- primary hash, secondary recno
+
+ sub sec_key4
+ {
+ #print "in sec_key4\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = length $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Recno -Filename => $Dfile2,
+ #-Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key4) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($secondary), 3 ;
+
+ ok $secondary->db_get(0, $v) != 0;
+ ok $secondary->db_get(1, $v) != 0;
+ ok $secondary->db_get(2, $v) != 0;
+ ok $secondary->db_get(3, $v) == 0;
+ ok $v eq "sea";
+
+ ok $secondary->db_get(4, $v) == 0;
+ is $v, "flag";
+
+ ok $secondary->db_get(5, $v) == 0;
+ is $v, "house";
+
+ # pget to primary database is illegal
+ ok $primary->db_pget(0, $pk, $v) != 0 ;
+
+ # pget to secondary database is ok
+ ok $secondary->db_pget(4, $pk, $v) == 0 ;
+ is $pk, 'red'
+ or warn "# $pk\n";;
+ is $v, 'flag';
+
+ ok my $p_cursor = $primary->db_cursor();
+ ok my $s_cursor = $secondary->db_cursor();
+
+ # c_get from primary
+ $k = 'green';
+ ok $p_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 'green';
+ is $v, 'house';
+
+ # c_get from secondary
+ $k = 3;
+ ok $s_cursor->c_get($k, $v, DB_SET) == 0;
+ is $k, 3 ;
+ is $v, 'sea';
+
+ # c_pget from primary database should fail
+ $k = 1;
+ ok $p_cursor->c_pget($k, $pk, $v, DB_SET) != 0;
+
+ # c_pget from secondary database
+ $k = 5;
+ ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
+ or diag "$BerkeleyDB::Error\n";
+ is $k, 5 ;
+ is $pk, 'green';
+ is $v, 'house';
+
+ # check put to secondary is illegal
+ ok $secondary->db_put(77, "dick") != 0;
+ is countRecords($secondary), 3 ;
+
+ # delete from primary
+ ok $primary->db_del("green") == 0 ;
+ is countRecords($primary), 2 ;
+
+ # check has been deleted in secondary
+ ok $secondary->db_get(5, $v) != 0;
+ is countRecords($secondary), 2 ;
+
+ # delete from secondary
+ ok $secondary->db_del(4) == 0 ;
+ is countRecords($secondary), 1 ;
+
+
+ # check deleted from primary
+ ok $primary->db_get("red", $v) != 0;
+ is countRecords($primary), 1 ;
+
+}
diff --git a/lang/perl/BerkeleyDB/t/db-4.3.t b/lang/perl/BerkeleyDB/t/db-4.3.t
new file mode 100644
index 00000000..3eed8247
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.3.t
@@ -0,0 +1,92 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use Test::More ;
+use util ;
+
+plan(skip_all => "this needs Berkeley DB 4.3.x or better\n" )
+ if $BerkeleyDB::db_version < 4.3;
+
+plan tests => 16;
+
+
+if (1)
+{
+ # -MsgFile with a filename
+ my $msgfile = "./msgfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $msgfile ;
+ ok my $env = new BerkeleyDB::Env( -MsgFile => $msgfile,
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ $env->stat_print();
+ ok length readFile($msgfile) > 0;
+
+ undef $env ;
+}
+
+
+{
+ # -MsgFile with a filehandle
+ use IO::File ;
+ my $msgfile = "./msgfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $msgfile ;
+ my $fh = new IO::File ">$msgfile" ;
+ ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ is $env->stat_print(), 0;
+ close $fh;
+ ok length readFile($msgfile) > 0;
+
+ undef $env ;
+}
+
+{
+ # -MsgFile with a filehandle
+ use IO::File ;
+ my $msgfile = "./msgfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $msgfile ;
+ my $Dfile = "db.db";
+ my $lex1 = new LexFile $Dfile ;
+ my $fh = new IO::File ">$msgfile" ;
+ ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
+ -Flags => DB_CREATE|DB_INIT_MPOOL,
+ -Home => $home) ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+ is $db->stat_print(), 0;
+ close $fh;
+ ok length readFile($msgfile) > 0;
+
+ undef $db;
+ undef $env ;
+}
+
+{
+ # txn_stat_print
+ use IO::File ;
+ my $msgfile = "./msgfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $msgfile ;
+ my $fh = new IO::File ">$msgfile" ;
+ ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
+ -Flags => DB_CREATE|DB_INIT_TXN,
+ -Home => $home) ;
+ is $env->txn_stat_print(), 0
+ or diag "$BerkeleyDB::Error";
+ close $fh;
+ ok length readFile($msgfile) > 0;
+
+ undef $env ;
+}
diff --git a/lang/perl/BerkeleyDB/t/db-4.4.t b/lang/perl/BerkeleyDB/t/db-4.4.t
new file mode 100644
index 00000000..b5b2183c
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.4.t
@@ -0,0 +1,57 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use Test::More ;
+use util ;
+
+plan(skip_all => "this needs Berkeley DB 4.4.x or better\n" )
+ if $BerkeleyDB::db_version < 4.4;
+
+plan tests => 5;
+
+{
+ title "Testing compact";
+
+ # db->db_compact
+
+ my $Dfile;
+ my $lex = new LexFile $Dfile ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0, " Created some data" ;
+
+ my $key;
+ my $end;
+ my %hash;
+ $hash{compact_filepercent} = 20;
+
+ ok $db->compact("red", "green", \%hash, 0, $end) == 0, " Compacted ok";
+
+ if (0)
+ {
+ diag "end at $end";
+ for my $key (sort keys %hash)
+ {
+ diag "[$key][$hash{$key}]\n";
+ }
+ }
+
+ ok $db->compact() == 0, " Compacted ok";
+}
+
diff --git a/lang/perl/BerkeleyDB/t/db-4.6.t b/lang/perl/BerkeleyDB/t/db-4.6.t
new file mode 100644
index 00000000..927b985a
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.6.t
@@ -0,0 +1,248 @@
+#!./perl -w
+
+
+use strict ;
+
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 4.6.x or better" )
+ if $BerkeleyDB::db_version < 4.6;
+
+ plan tests => 69;
+}
+
+umask(0);
+
+{
+ # db->associate -- secondary keys returning DB_DBT_MULTIPLE
+
+ sub sec_key
+ {
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = ["a","b", "c"];
+
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key) == 0 ;
+
+ # add data to the primary
+ ok $primary->db_put("foo", "bar") == 0;
+
+ # check the records in the secondary (there should be three "a", "b", "c")
+ is countRecords($secondary), 3 ;
+
+ ok $secondary->db_get("a", $v) == 0;
+ is $v, "bar";
+
+ ok $secondary->db_get("b", $v) == 0;
+ is $v, "bar";
+
+ ok $secondary->db_get("c", $v) == 0;
+ is $v, "bar";
+}
+
+{
+ # db->associate -- secondary keys returning DB_DBT_MULTIPLE, but with
+ # one
+
+ sub sec_key1
+ {
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = ["a"];
+
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key1) == 0 ;
+
+ # add data to the primary
+ ok $primary->db_put("foo", "bar") == 0;
+
+ # check the records in the secondary (there should be three "a", "b", "c")
+ is countRecords($secondary), 1 ;
+
+ ok $secondary->db_get("a", $v) == 0;
+ is $v, "bar";
+
+}
+
+{
+ # db->associate -- multiple secondary keys
+
+ sub sec_key_mult
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = [ split ',', $pdata ] ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2);
+ my $lex = new LexFile $Dfile1, $Dfile2 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key_mult) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ "foo" => "",
+ "bar" => "hello,goodbye",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($secondary), 5 ;
+
+ ok $secondary->db_get("house", $v) == 0;
+ ok $v eq "house";
+
+ ok $secondary->db_get("sea", $v) == 0;
+ ok $v eq "sea";
+
+ ok $secondary->db_get("flag", $v) == 0;
+ ok $v eq "flag";
+
+ ok $secondary->db_get("hello", $v) == 0;
+ ok $v eq "hello,goodbye";
+
+ ok $secondary->db_get("goodbye", $v) == 0;
+ ok $v eq "hello,goodbye";
+
+ # pget to primary database is illegal
+ ok $primary->db_pget('red', $pk, $v) != 0 ;
+
+ # pget to secondary database is ok
+ ok $secondary->db_pget('house', $pk, $v) == 0 ;
+ ok $pk eq 'green';
+ ok $v eq 'house';
+
+ # pget to secondary database is ok
+ ok $secondary->db_pget('hello', $pk, $v) == 0 ;
+ ok $pk eq 'bar';
+ ok $v eq 'hello,goodbye';
+
+ # pget to DB_GET_BOTH from secondary database
+ $k = 'house';
+ $pk = 'green';
+ ok $secondary->db_pget($k, $pk, $v, DB_GET_BOTH) == 0 ;
+ ok $k eq 'house';
+ ok $v eq 'house';
+
+ ok my $p_cursor = $primary->db_cursor();
+ ok my $s_cursor = $secondary->db_cursor();
+
+ # c_get from primary
+ $k = 'green';
+ ok $p_cursor->c_get($k, $v, DB_SET) == 0;
+ ok $k eq 'green';
+ ok $v eq 'house';
+
+ # c_get from secondary
+ $k = 'sea';
+ ok $s_cursor->c_get($k, $v, DB_SET) == 0;
+ ok $k eq 'sea';
+ ok $v eq 'sea';
+
+ # c_pget from primary database should fail
+ $k = 1;
+ ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
+
+ # c_pget from secondary database
+ $k = 'flag';
+ ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
+ ok $k eq 'flag';
+ ok $pk eq 'red';
+ ok $v eq 'flag';
+
+ # c_pget with DB_GET_BOTH from secondary database
+ $k = 'house';
+ $pk = 'green';
+ ok $s_cursor->c_pget($k, $pk, $v, DB_GET_BOTH) == 0;
+ ok $k eq 'house';
+ ok $v eq 'house';
+
+ # check put to secondary is illegal
+ ok $secondary->db_put("tom", "dick") != 0;
+ is countRecords($secondary), 5 ;
+
+ # delete from primary
+ ok $primary->db_del("green") == 0 ;
+ is countRecords($primary), 4 ;
+
+ # check has been deleted in secondary
+ ok $secondary->db_get("house", $v) != 0;
+ is countRecords($secondary), 4 ;
+
+ # delete from secondary
+ ok $secondary->db_del('flag') == 0 ;
+ is countRecords($secondary), 3 ;
+
+
+ # check deleted from primary
+ ok $primary->db_get("red", $v) != 0;
+ is countRecords($primary), 3 ;
+}
+
diff --git a/lang/perl/BerkeleyDB/t/db-4.7.t b/lang/perl/BerkeleyDB/t/db-4.7.t
new file mode 100644
index 00000000..810a50be
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.7.t
@@ -0,0 +1,42 @@
+#!./perl -w
+
+use strict ;
+
+
+use lib 't' ;
+
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+plan(skip_all => "this needs Berkeley DB 4.7.x or better\n" )
+ if $BerkeleyDB::db_version < 4.7;
+
+plan tests => 7;
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ chdir "./fred" ;
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_LOG @StdErrFile;
+
+ ok $env->log_get_config( DB_LOG_AUTO_REMOVE, my $on ) == 0, "get config" ;
+ ok !$on, "config value" ;
+
+ ok $env->log_set_config( DB_LOG_AUTO_REMOVE, 1 ) == 0;
+
+ ok $env->log_get_config( DB_LOG_AUTO_REMOVE, $on ) == 0;
+ ok $on;
+
+ chdir ".." ;
+ undef $env ;
+}
+
+# test -Verbose
+# test -Flags
+# db_value_set
diff --git a/lang/perl/BerkeleyDB/t/db-4.8.t b/lang/perl/BerkeleyDB/t/db-4.8.t
new file mode 100644
index 00000000..e3beae78
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.8.t
@@ -0,0 +1,324 @@
+#!./perl -w
+
+use strict ;
+
+
+use lib 't' ;
+
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+plan(skip_all => "this needs Berkeley DB 4.8.x or better\n")
+ if $BerkeleyDB::db_version < 4.8;
+
+plan tests => 58;
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ # db->associate_foreign -- DB_FOREIGN_CASCADE
+
+ sub sec_key
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2, $Dfile3);
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key) == 0;
+
+ # create secondary database
+ ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $foreign->associate_foreign($secondary, undef, DB_FOREIGN_CASCADE) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $foreign->db_put($v, 1) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 3 ;
+ is countRecords($foreign), 3 ;
+
+ # deleting from the foreign will cascade
+ ok $foreign->db_del("flag") == 0;
+ is countRecords($primary), 2 ;
+ is countRecords($secondary), 2 ;
+ is countRecords($foreign), 2 ;
+
+ cmp_ok $foreign->db_get("flag", $v), '==', DB_NOTFOUND;
+ cmp_ok $secondary->db_get("flag", $v), '==', DB_NOTFOUND;
+ cmp_ok $primary->db_get("red", $v), '==', DB_NOTFOUND;
+
+ # adding to the primary when no foreign key will fail
+ cmp_ok $primary->db_put("hello", "world"), '==', DB_FOREIGN_CONFLICT;
+
+ ok $foreign->db_put("world", "hello") == 0;
+
+ ok $primary->db_put("hello", "world") == '0';
+
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 3 ;
+ is countRecords($foreign), 3 ;
+}
+
+{
+ # db->associate_foreign -- DB_FOREIGN_ABORT
+
+ sub sec_key2
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ $_[0] = $pdata ;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2, $Dfile3);
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key2) == 0;
+
+ # create secondary database
+ ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $foreign->associate_foreign($secondary, undef, DB_FOREIGN_ABORT) == 0;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $foreign->db_put($v, 1) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 3 ;
+ is countRecords($foreign), 3 ;
+
+ # deleting from the foreign will fail
+ cmp_ok $foreign->db_del("flag"), '==', DB_FOREIGN_CONFLICT;
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 3 ;
+ is countRecords($foreign), 3 ;
+
+}
+
+{
+ # db->associate_foreign -- DB_FOREIGN_NULLIFY
+
+ use constant INVALID => "invalid";
+
+ sub sec_key3
+ {
+ #print "in sec_key\n";
+ my $pkey = shift ;
+ my $pdata = shift ;
+
+ if ($pdata eq INVALID)
+ {
+ #print "BAD\n";
+ return DB_DONOTINDEX;
+ }
+
+ $_[0] = $pdata ;
+ return 0;
+ }
+
+ sub nullify_cb
+ {
+ my $key = \$_[0];
+ my $value = \$_[1];
+ my $foreignkey = \$_[2];
+ my $changed = \$_[3] ;
+
+ #print "key[$$key], value[$$value], foreign[$$foreignkey], changed[$$changed]\n";
+
+ if ($$value eq 'sea')
+ {
+ #print "SEA\n";
+ $$value = INVALID;
+ $$changed = 1;
+ return 0;
+ }
+
+ $$changed = 0;
+ return 0;
+ }
+
+ my ($Dfile1, $Dfile2, $Dfile3);
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
+ -Flags => DB_CREATE ;
+
+ # create secondary database
+ ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ ok $primary->associate($secondary, \&sec_key3) == 0;
+
+ # create secondary database
+ ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
+ -Flags => DB_CREATE ;
+
+ # associate primary with secondary
+ cmp_ok $foreign->associate_foreign($secondary, \&nullify_cb, DB_FOREIGN_NULLIFY), '==', 0
+ or diag "$BerkeleyDB::Error\n";
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $foreign->db_put($v, 1) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v) ;
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 3 ;
+ is countRecords($foreign), 3, "count is 3" ;
+
+ # deleting from the foreign will pass, but the other dbs will not be
+ # affected
+ cmp_ok $foreign->db_del("sea"), '==', 0, "delete"
+ or diag "$BerkeleyDB::Error\n";
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 2 ;
+ is countRecords($foreign), 2 ;
+
+
+ # deleting from the foreign will pass, but the other dbs will not be
+ # affected
+ cmp_ok $foreign->db_del("flag"), '==', 0, "delete"
+ or diag "$BerkeleyDB::Error\n";
+ is countRecords($primary), 3 ;
+ is countRecords($secondary), 2 ;
+ is countRecords($foreign), 1 ;
+
+}
+
+{
+ # db->set_bt_compress
+
+ my ($Dfile1, $Dfile2, $Dfile3);
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash ;
+ my $status;
+ my ($k, $v, $pk) = ('','','');
+
+ # create primary database
+ ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
+ -set_bt_compress => 1,
+ -Flags => DB_CREATE ;
+
+ # add data to the primary
+ my %data = (
+ "red" => "flag",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ my $r = $primary->db_put($k, $v);
+ #print "put $r $BerkeleyDB::Error\n";
+ $ret += $r;
+ }
+ ok $ret == 0 ;
+
+ # check the records in the secondary
+ is countRecords($primary), 3 ;
+}
diff --git a/lang/perl/BerkeleyDB/t/db-4.x.t b/lang/perl/BerkeleyDB/t/db-4.x.t
new file mode 100644
index 00000000..73ded4b5
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/db-4.x.t
@@ -0,0 +1,56 @@
+#!./perl -w
+
+use strict ;
+use lib 't';
+use BerkeleyDB;
+use Test::More;
+use util ;
+
+plan(skip_all => "this needs Berkeley DB 4.x.x or better\n" )
+ if $BerkeleyDB::db_version < 4;
+
+
+plan tests => 9;
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $db = BerkeleyDB::Btree->new(
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+) || die "Cannot open file $Dfile: $! $BerkeleyDB::Error\n" ;
+
+my $cursor = $db->db_cursor();
+
+my @pairs = qw(
+ Alabama/Athens
+ Alabama/Florence
+ Alaska/Anchorage
+ Alaska/Fairbanks
+ Arizona/Avondale
+ Arizona/Florence
+);
+
+for (@pairs) {
+ $db->db_put(split '/');
+}
+
+my @tests = (
+ ["Alaska", "Fa", "Alaska", "Fairbanks"],
+ ["Arizona", "Fl", "Arizona", "Florence"],
+ ["Alaska", "An", "Alaska", "Anchorage"],
+);
+
+#my $i;
+while (my $test = shift @tests) {
+ my ($k1, $v1, $k2, $v2) = @$test;
+ ok $cursor->c_get($k1, $v1, DB_GET_BOTH_RANGE) == 0;
+ is $k1, $k2;
+ is $v1, $v2;
+}
+
+undef $db;
+unlink $Dfile;
diff --git a/lang/perl/BerkeleyDB/t/destroy.t b/lang/perl/BerkeleyDB/t/destroy.t
new file mode 100644
index 00000000..c8f3c968
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/destroy.t
@@ -0,0 +1,100 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+plan tests => 15;
+
+my $Dfile = "dbhash.tmp";
+my $home = "./fred" ;
+
+umask(0);
+
+{
+ # let object destruction kill everything
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ is $count, 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ is $count, 0 ;
+
+ #undef $txn ;
+ #undef $cursor ;
+ #undef $db1 ;
+ #undef $env ;
+ #untie %hash ;
+
+}
+
+{
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $cursor ;
+ my ($k, $v) = ("", "") ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ my $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ is $count, 0 ;
+}
+
+
diff --git a/lang/perl/BerkeleyDB/t/encode.t b/lang/perl/BerkeleyDB/t/encode.t
new file mode 100644
index 00000000..096f806f
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/encode.t
@@ -0,0 +1,72 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More ;
+
+BEGIN
+{
+ eval { require Encode; };
+
+ plan skip_all => "Encode is not available"
+ if $@;
+
+ plan tests => 8;
+
+ use_ok('charnames', qw{greek});
+}
+
+
+use charnames qw{greek};
+
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+{
+ # UTF8
+ #
+
+ #use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_fetch_key (sub { $_ = Encode::decode_utf8($_) if defined $_ });
+ $db->filter_store_key (sub { $_ = Encode::encode_utf8($_) if defined $_ });
+ $db->filter_fetch_value (sub { $_ = Encode::decode_utf8($_) if defined $_ });
+ $db->filter_store_value (sub { $_ = Encode::encode_utf8($_) if defined $_ });
+
+ $h{"\N{alpha}"} = "alpha";
+ $h{"gamma"} = "\N{gamma}";
+
+ is $h{"\N{alpha}"}, "alpha";
+ is $h{"gamma"}, "\N{gamma}";
+
+ undef $db ;
+ untie %h;
+
+ my %newH;
+ ok $db = tie %newH, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $newH{"fred"} = "joe" ;
+ is $newH{"fred"}, "joe";
+
+ is $newH{"gamma"}, "\xCE\xB3";
+ is $newH{"\xCE\xB1"}, "alpha";
+
+ undef $db ;
+ untie %newH;
+ unlink $Dfile;
+}
diff --git a/lang/perl/BerkeleyDB/t/encrypt.t b/lang/perl/BerkeleyDB/t/encrypt.t
new file mode 100644
index 00000000..f8167a62
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/encrypt.t
@@ -0,0 +1,636 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 4.1.x or better" )
+ if $BerkeleyDB::db_version < 4.1;
+
+ # Is encryption available?
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => {Password => "abc",
+ Flags => DB_ENCRYPT_AES
+ };
+
+ plan skip_all => "encryption support not present"
+ if $BerkeleyDB::Error =~ /Operation not supported/;
+
+ plan tests => 80;
+}
+
+
+umask(0);
+
+{
+ eval
+ {
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => 1,
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Encrypt parameter must be a hash reference at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => {},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => {Password => "fred"},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => {Flags => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Env @StdErrFile,
+ -Encrypt => {Fred => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^\Qunknown key value(s) Fred at/;
+
+}
+
+{
+ # new BerkeleyDB::Env -Encrypt =>
+
+ # create an environment with a Home
+ my $home = "./fred" ;
+ #mkdir $home;
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env @StdErrFile,
+ -Home => $home,
+ -Encrypt => {Password => "abc",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Flags => DB_CREATE | DB_INIT_MPOOL ;
+
+
+
+ my $Dfile = "abc.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE,
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # once the database is created, do not need to specify DB_ENCRYPT
+ ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+ $v = '';
+ ok ! $db1->db_get("red", $v) ;
+ ok $v eq $data{"red"},
+ undef $db1;
+ undef $env;
+
+ # open a database without specifying encryption
+ ok ! new BerkeleyDB::Hash -Filename => "$home/$Dfile";
+
+ ok ! new BerkeleyDB::Env
+ -Home => $home,
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Flags => DB_CREATE | DB_INIT_MPOOL ;
+}
+
+{
+ eval
+ {
+ my $env = new BerkeleyDB::Hash
+ -Encrypt => 1,
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Encrypt parameter must be a hash reference at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Hash
+ -Encrypt => {},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Hash
+ -Encrypt => {Password => "fred"},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Hash
+ -Encrypt => {Flags => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Hash
+ -Encrypt => {Fred => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^\Qunknown key value(s) Fred at/;
+
+}
+
+{
+ eval
+ {
+ my $env = new BerkeleyDB::Btree
+ -Encrypt => 1,
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Encrypt parameter must be a hash reference at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Btree
+ -Encrypt => {},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Btree
+ -Encrypt => {Password => "fred"},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Btree
+ -Encrypt => {Flags => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Btree
+ -Encrypt => {Fred => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^\Qunknown key value(s) Fred at/;
+
+}
+
+{
+ eval
+ {
+ my $env = new BerkeleyDB::Queue
+ -Encrypt => 1,
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Encrypt parameter must be a hash reference at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Queue
+ -Encrypt => {},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Queue
+ -Encrypt => {Password => "fred"},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Queue
+ -Encrypt => {Flags => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Queue
+ -Encrypt => {Fred => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^\Qunknown key value(s) Fred at/;
+
+}
+
+{
+ eval
+ {
+ my $env = new BerkeleyDB::Recno
+ -Encrypt => 1,
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Encrypt parameter must be a hash reference at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Recno
+ -Encrypt => {},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Recno
+ -Encrypt => {Password => "fred"},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Recno
+ -Encrypt => {Flags => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
+
+ eval
+ {
+ my $env = new BerkeleyDB::Recno
+ -Encrypt => {Fred => 1},
+ -Flags => DB_CREATE ;
+ };
+ ok $@ =~ /^\Qunknown key value(s) Fred at/;
+
+}
+
+
+{
+ # new BerkeleyDB::Hash -Encrypt =>
+
+ my $Dfile = "abcd.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # attempt to open a database without specifying encryption
+ ok ! new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+
+ # try opening with the wrong password
+ ok ! new BerkeleyDB::Hash -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ # read the encrypted data
+ ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ $v = '';
+ ok ! $db1->db_get("red", $v) ;
+ ok $v eq $data{"red"};
+ # check there are three records
+ ok countRecords($db1) == 3 ;
+ undef $db1;
+}
+
+{
+ # new BerkeleyDB::Btree -Encrypt =>
+
+ my $Dfile = "abcd.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Btree
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # attempt to open a database without specifying encryption
+ ok ! new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+
+ # try opening with the wrong password
+ ok ! new BerkeleyDB::Btree -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ # read the encrypted data
+ ok my $db1 = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ $v = '';
+ ok ! $db1->db_get("red", $v) ;
+ ok $v eq $data{"red"};
+ # check there are three records
+ ok countRecords($db1) == 3 ;
+ undef $db1;
+}
+
+{
+ # new BerkeleyDB::Queue -Encrypt =>
+
+ my $Dfile = "abcd.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Queue
+ -Filename => $Dfile,
+ -Len => 5,
+ -Pad => "x",
+ -Flags => DB_CREATE,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ 1 => 2,
+ 2 => "house",
+ 3 => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # attempt to open a database without specifying encryption
+ ok ! new BerkeleyDB::Queue -Filename => $Dfile,
+ -Len => 5,
+ -Pad => "x",
+ -Flags => DB_CREATE ;
+
+
+ # try opening with the wrong password
+ ok ! new BerkeleyDB::Queue -Filename => $Dfile,
+ -Len => 5,
+ -Pad => "x",
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ # read the encrypted data
+ ok my $db1 = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Len => 5,
+ -Pad => "x",
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ $v = '';
+ ok ! $db1->db_get(3, $v) ;
+ ok $v eq fillout($data{3}, 5, 'x');
+ # check there are three records
+ ok countRecords($db1) == 3 ;
+ undef $db1;
+}
+
+{
+ # new BerkeleyDB::Recno -Encrypt =>
+
+ my $Dfile = "abcd.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Recno
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ 1 => 2,
+ 2 => "house",
+ 3 => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # attempt to open a database without specifying encryption
+ ok ! new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+
+ # try opening with the wrong password
+ ok ! new BerkeleyDB::Recno -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ # read the encrypted data
+ ok my $db1 = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ $v = '';
+ ok ! $db1->db_get(3, $v) ;
+ ok $v eq $data{3};
+ # check there are three records
+ ok countRecords($db1) == 3 ;
+ undef $db1;
+}
+
+{
+ # new BerkeleyDB::Unknown -Encrypt =>
+
+ my $Dfile = "abcd.enc";
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash
+ -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # check there are three records
+ ok countRecords($db) == 3 ;
+
+ undef $db;
+
+ # attempt to open a database without specifying encryption
+ ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+
+ # try opening with the wrong password
+ ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "def",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ # read the encrypted data
+ ok my $db1 = new BerkeleyDB::Unknown -Filename => $Dfile,
+ -Filename => $Dfile,
+ -Encrypt => {Password => "beta",
+ Flags => DB_ENCRYPT_AES
+ },
+ -Property => DB_ENCRYPT ;
+
+
+ $v = '';
+ ok ! $db1->db_get("red", $v) ;
+ ok $v eq $data{"red"};
+ # check there are three records
+ ok countRecords($db1) == 3 ;
+ undef $db1;
+}
+
diff --git a/lang/perl/BerkeleyDB/t/env.t b/lang/perl/BerkeleyDB/t/env.t
new file mode 100644
index 00000000..97fdeaaf
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/env.t
@@ -0,0 +1,273 @@
+#!./perl -w
+
+use strict ;
+
+
+use lib 't' ;
+
+BEGIN {
+ $ENV{LC_ALL} = 'de_DE@euro';
+}
+
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+plan tests => 53;
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+my $version_major = 0;
+
+{
+ # db version stuff
+ my ($major, $minor, $patch) = (0, 0, 0) ;
+
+ ok my $VER = BerkeleyDB::DB_VERSION_STRING ;
+ ok my $ver = BerkeleyDB::db_version($version_major, $minor, $patch) ;
+ ok $VER eq $ver ;
+ ok $version_major > 1 ;
+ ok defined $minor ;
+ ok defined $patch ;
+}
+
+{
+ # Check for invalid parameters
+ my $env ;
+ eval ' $env = new BerkeleyDB::Env( -Stupid => 3) ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/, "Unknown key" ;
+
+ eval ' $env = new BerkeleyDB::Env( -Bad => 2, -Home => "/tmp", -Stupid => 3) ; ' ;
+ ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ ;
+
+ eval ' $env = new BerkeleyDB::Env (-Config => {"fred" => " "} ) ; ' ;
+ ok !$env ;
+ ok $BerkeleyDB::Error =~ /^(illegal name-value pair|Invalid argument)/ ;
+ #print " $BerkeleyDB::Error\n";
+}
+
+{
+ # create a very simple environment
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ chdir "./fred" ;
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE,
+ @StdErrFile;
+ chdir ".." ;
+ undef $env ;
+}
+
+{
+ # create an environment with a Home
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ ok my $env = new BerkeleyDB::Env -Home => $home,
+ -Flags => DB_CREATE ;
+
+ undef $env ;
+}
+
+{
+ # make new fail.
+ my $home = "./not_there" ;
+ rmtree $home ;
+ ok ! -d $home ;
+ my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_INIT_LOCK ;
+ ok ! $env ;
+ ok $! != 0 || $^E != 0, "got error" ;
+
+ rmtree $home ;
+}
+
+{
+ # Config
+ use Cwd ;
+ my $cwd = cwd() ;
+ my $home = "$cwd/fred" ;
+ my $data_dir = "$home/data_dir" ;
+ my $log_dir = "$home/log_dir" ;
+ my $data_file = "data.db" ;
+ ok my $lexD = new LexDir($home) ;
+ ok -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
+ ok -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
+ my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Config => { DB_DATA_DIR => $data_dir,
+ DB_LOG_DIR => $log_dir
+ },
+ -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok $env ;
+
+ ok my $txn = $env->txn_begin() ;
+
+ my %hash ;
+ ok tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ $hash{"abc"} = 123 ;
+ $hash{"def"} = 456 ;
+
+ $txn->txn_commit() ;
+
+ untie %hash ;
+
+ undef $txn ;
+ undef $env ;
+}
+
+sub chkMsg
+{
+ my $prefix = shift || '';
+
+ $prefix = "$prefix: " if $prefix;
+
+ my $ErrMsg = join "|", map { "$prefix$_" }
+ 'illegal flag specified to (db_open|DB->open)',
+ '(BDB\d+ )?DB_AUTO_COMMIT may not be specified in non-transactional environment';
+
+ return 1 if $BerkeleyDB::Error =~ /^$ErrMsg/ ;
+ warn "# $BerkeleyDB::Error\n" ;
+ return 0;
+}
+
+{
+ # -ErrFile with a filename
+ my $errfile = "./errfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $errfile ;
+ ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok !$db ;
+
+ my $ErrMsg = join "'", 'illegal flag specified to (db_open|DB->open)',
+ 'DB_AUTO_COMMIT may not be specified in non-transactional environment';
+
+ ok chkMsg();
+ ok -e $errfile ;
+ my $contents = docat($errfile) ;
+ chomp $contents ;
+ ok $BerkeleyDB::Error eq $contents ;
+
+ undef $env ;
+}
+
+{
+ # -ErrFile with a filehandle
+ use IO::File ;
+ my $errfile = "./errfile" ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $lex = new LexFile $errfile ;
+ my $fh = new IO::File ">$errfile" ;
+ ok my $env = new BerkeleyDB::Env( -ErrFile => $fh,
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok !$db ;
+
+ ok chkMsg();
+ ok -e $errfile ;
+ my $contents = docat($errfile) ;
+ chomp $contents ;
+ ok $BerkeleyDB::Error eq $contents ;
+
+ undef $env ;
+}
+
+{
+ # -ErrPrefix
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ my $errfile = "./errfile" ;
+ my $lex = new LexFile $errfile ;
+ ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
+ -ErrPrefix => "PREFIX",
+ -Flags => DB_CREATE,
+ -Home => $home) ;
+ my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok !$db ;
+
+ ok chkMsg('PREFIX');
+ ok -e $errfile ;
+ my $contents = docat($errfile) ;
+ chomp $contents ;
+ ok $BerkeleyDB::Error eq $contents ;
+
+ # change the prefix on the fly
+ my $old = $env->errPrefix("NEW ONE") ;
+ ok $old eq "PREFIX" ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => -1;
+ ok !$db ;
+ ok chkMsg('NEW ONE');
+ $contents = docat($errfile) ;
+ chomp $contents ;
+ ok $contents =~ /$BerkeleyDB::Error$/ ;
+ undef $env ;
+}
+
+{
+ # test db_appexit
+ use Cwd ;
+ my $cwd = cwd() ;
+ my $home = "$cwd/fred" ;
+ my $data_dir = "$home/data_dir" ;
+ my $log_dir = "$home/log_dir" ;
+ my $data_file = "data.db" ;
+ ok my $lexD = new LexDir($home);
+ ok -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
+ ok -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
+ my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Config => { DB_DATA_DIR => $data_dir,
+ DB_LOG_DIR => $log_dir
+ },
+ -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok $env ;
+
+ ok my $txn_mgr = $env->TxnMgr() ;
+
+ ok $env->db_appexit() == 0 ;
+
+}
+
+{
+ # attempt to open a new environment without DB_CREATE
+ # should fail with Berkeley DB 3.x or better.
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home) ;
+ chdir "./fred" ;
+ my $env = new BerkeleyDB::Env -Home => $home, -Flags => DB_CREATE ;
+ ok $version_major == 2 ? $env : ! $env ;
+
+ # The test below is not portable -- the error message returned by
+ # $BerkeleyDB::Error is locale dependant.
+
+ #ok $version_major == 2 ? 1
+ # : $BerkeleyDB::Error =~ /No such file or directory/ ;
+ # or print "# BerkeleyDB::Error is $BerkeleyDB::Error\n";
+ chdir ".." ;
+ undef $env ;
+}
+
+# test -Verbose
+# test -Flags
+# db_value_set
diff --git a/lang/perl/BerkeleyDB/t/examples.t b/lang/perl/BerkeleyDB/t/examples.t
new file mode 100644
index 00000000..b70fba6c
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/examples.t
@@ -0,0 +1,403 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use lib 't';
+use BerkeleyDB;
+use Test::More;
+use util;
+
+plan tests => 7;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $x = $BerkeleyDB::Error;
+my $redirect = "xyzt" ;
+ {
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del($redirect), <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del($redirect), <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<'EOM') ;
+Smith
+Wall
+mouse
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+ $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+abc\x00 -> def\x00
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+ $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot Open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ my $val = pack("i", 123) ;
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+$val -> def
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ if ($FA) {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+ unlink $filename ;
+ } else {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $db = tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $db->push("green", "black") ;
+
+ my $elements = $db->length() ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $db->pop ;
+ print "popped $last\n" ;
+
+ $db->unshift("white") ;
+ my $first = $db->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ undef $db ;
+ untie @h ;
+ unlink $filename ;
+ }
+
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+EOM
+
+}
+
diff --git a/lang/perl/BerkeleyDB/t/examples.t.T b/lang/perl/BerkeleyDB/t/examples.t.T
new file mode 100644
index 00000000..7b9abb58
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/examples.t.T
@@ -0,0 +1,417 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use lib 't';
+use BerkeleyDB;
+use Test::More;
+use util;
+
+plan tests => 7;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $x = $BerkeleyDB::Error;
+my $redirect = "xyzt" ;
+ {
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN simpleHash
+ use strict ;
+ use BerkeleyDB ;
+ use vars qw( %h $k $v ) ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ tie %h, "BerkeleyDB::Hash",
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+## END simpleHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del($redirect), <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN simpleHash2
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("apple", "red") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("banana", "yellow") ;
+ $db->db_put("tomato", "red") ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
+
+ # Delete a key/value pair.
+ $db->db_del("apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END simpleHash2
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del($redirect), <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN btreeSimple
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+## END btreeSimple
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<'EOM') ;
+Smith
+Wall
+mouse
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN btreeSortOrder
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "tree" ;
+ unlink $filename ;
+ my %h ;
+ tie %h, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Compare => sub { lc $_[0] cmp lc $_[1] }
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+## END btreeSortOrder
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN nullFilter
+ use strict ;
+ use BerkeleyDB ;
+
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+## END nullFilter
+ $db = tie %hash, 'BerkeleyDB::Hash',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+abc\x00 -> def\x00
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN intFilter
+ use strict ;
+ use BerkeleyDB ;
+ my %hash ;
+ my $filename = "filt.db" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+## END intFilter
+ $db = tie %hash, 'BerkeleyDB::Btree',
+ -Filename => $filename,
+ -Flags => DB_CREATE
+ or die "Cannot Open $filename: $!\n" ;
+ while (($k, $v) = each %hash)
+ { print "$k -> $v\n" }
+ undef $db ;
+ untie %hash ;
+
+ unlink $filename ;
+ }
+
+ my $val = pack("i", 123) ;
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+$val -> def
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ if ($FA) {
+## BEGIN simpleRecno
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ untie @h ;
+## END simpleRecno
+ unlink $filename ;
+ } else {
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $db = tie @h, 'BerkeleyDB::Recno',
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_RENUMBER
+ or die "Cannot open $filename: $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $db->push("green", "black") ;
+
+ my $elements = $db->length() ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $db->pop ;
+ print "popped $last\n" ;
+
+ $db->unshift("white") ;
+ my $first = $db->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ undef $db ;
+ untie @h ;
+ unlink $filename ;
+ }
+
+ }
+
+ #print "[" . docat($redirect) . "]\n" ;
+ is(docat_del($redirect), <<"EOM") ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+EOM
+
+}
+
diff --git a/lang/perl/BerkeleyDB/t/examples3.t b/lang/perl/BerkeleyDB/t/examples3.t
new file mode 100644
index 00000000..93069b2b
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/examples3.t
@@ -0,0 +1,139 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use lib 't';
+use BerkeleyDB;
+use Test::More;
+use util ;
+
+#BEGIN
+#{
+# if ($BerkeleyDB::db_version < 3) {
+# print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;
+# exit 0 ;
+# }
+#}
+
+plan(skip_all => "this needs Berkeley DB 3.x or better\n" )
+ if $BerkeleyDB::db_version < 3;
+
+
+
+plan tests => 2;
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del_sort($redirect), <<'EOM') ;
+green -> apple
+green -> banana
+orange -> orange
+red -> apple
+red -> tomato
+yellow -> banana
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del_sort($redirect), <<'EOM') ;
+green -> apple
+green -> banana
+orange -> orange
+red -> apple
+red -> tomato
+yellow -> banana
+EOM
+
+}
+
+
diff --git a/lang/perl/BerkeleyDB/t/examples3.t.T b/lang/perl/BerkeleyDB/t/examples3.t.T
new file mode 100644
index 00000000..8ba8ab96
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/examples3.t.T
@@ -0,0 +1,143 @@
+#!./perl -w
+
+use strict ;
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use lib 't';
+use BerkeleyDB;
+use Test::More;
+use util ;
+
+#BEGIN
+#{
+# if ($BerkeleyDB::db_version < 3) {
+# print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;
+# exit 0 ;
+# }
+#}
+
+plan(skip_all => "this needs Berkeley DB 3.x or better\n" )
+ if $BerkeleyDB::db_version < 3;
+
+
+
+plan tests => 2;
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+my $redirect = "xyzt" ;
+
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN dupHash
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END dupHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del_sort($redirect), <<'EOM') ;
+green -> apple
+green -> banana
+orange -> orange
+red -> apple
+red -> tomato
+yellow -> banana
+EOM
+
+}
+
+{
+my $redirect = "xyzt" ;
+ {
+
+ my $redirectObj = new Redirect $redirect ;
+
+## BEGIN dupSortHash
+ use strict ;
+ use BerkeleyDB ;
+
+ my $filename = "fruit" ;
+ unlink $filename ;
+ my $db = new BerkeleyDB::Hash
+ -Filename => $filename,
+ -Flags => DB_CREATE,
+ -Property => DB_DUP | DB_DUPSORT
+ or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
+
+ # Add a few key/value pairs to the file
+ $db->db_put("red", "apple") ;
+ $db->db_put("orange", "orange") ;
+ $db->db_put("green", "banana") ;
+ $db->db_put("yellow", "banana") ;
+ $db->db_put("red", "tomato") ;
+ $db->db_put("green", "apple") ;
+
+ # print the contents of the file
+ my ($k, $v) = ("", "") ;
+ my $cursor = $db->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { print "$k -> $v\n" }
+
+ undef $cursor ;
+ undef $db ;
+## END dupSortHash
+ unlink $filename ;
+ }
+
+ #print "[" . docat($redirect) . "]" ;
+ is(docat_del_sort($redirect), <<'EOM') ;
+green -> apple
+green -> banana
+orange -> orange
+red -> apple
+red -> tomato
+yellow -> banana
+EOM
+
+}
+
+
diff --git a/lang/perl/BerkeleyDB/t/filter.t b/lang/perl/BerkeleyDB/t/filter.t
new file mode 100644
index 00000000..edb264fc
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/filter.t
@@ -0,0 +1,326 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+plan tests => 52;
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+{
+ # DBM Filter tests
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok checkOutput( "", "fred", "", "joe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $h{"fred"} eq "joe";
+ # fk sk fv sv
+ ok checkOutput( "", "fred", "joe", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $db->FIRSTKEY() eq "fred" ;
+ # fk sk fv sv
+ ok checkOutput( "fred", "", "", "") ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok checkOutput( "", "fred", "", "Jxe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $h{"Fred"} eq "[Jxe]";
+ print "$h{'Fred'}\n";
+ # fk sk fv sv
+ ok checkOutput( "", "fred", "[Jxe]", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $db->FIRSTKEY() eq "FRED" ;
+ # fk sk fv sv
+ ok checkOutput( "FRED", "", "", "") ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok checkOutput( "", "fred", "", "joe") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $h{"fred"} eq "joe";
+ ok checkOutput( "", "fred", "joe", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $db->FIRSTKEY() eq "fred" ;
+ ok checkOutput( "fred", "", "", "") ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok checkOutput( "", "", "", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $h{"fred"} eq "joe";
+ ok checkOutput( "", "", "", "") ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok $db->FIRSTKEY() eq "fred" ;
+ ok checkOutput( "", "", "", "") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok $result{"store key"} eq "store key - 1: [fred]" ;
+ ok $result{"store value"} eq "store value - 1: [joe]" ;
+ ok ! defined $result{"fetch key"} ;
+ ok ! defined $result{"fetch value"} ;
+ ok $_ eq "original" ;
+
+ ok $db->FIRSTKEY() eq "fred" ;
+ ok $result{"store key"} eq "store key - 1: [fred]" ;
+ ok $result{"store value"} eq "store value - 1: [joe]" ;
+ ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok ! defined $result{"fetch value"} ;
+ ok $_ eq "original" ;
+
+ $h{"jim"} = "john" ;
+ ok $result{"store key"} eq "store key - 2: [fred jim]" ;
+ ok $result{"store value"} eq "store value - 2: [joe john]" ;
+ ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok ! defined $result{"fetch value"} ;
+ ok $_ eq "original" ;
+
+ ok $h{"fred"} eq "joe" ;
+ ok $result{"store key"} eq "store key - 3: [fred jim fred]" ;
+ ok $result{"store value"} eq "store value - 2: [joe john]" ;
+ ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
+ ok $result{"fetch value"} eq "fetch value - 1: [joe]" ;
+ ok $_ eq "original" ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok $@ =~ /^recursion detected in filter_store_key at/ ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # Check that DBM Filter can cope with read-only $_
+
+ #use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ $db->filter_fetch_key (sub { }) ;
+ $db->filter_store_key (sub { }) ;
+ $db->filter_fetch_value (sub { }) ;
+ $db->filter_store_value (sub { }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok($h{"fred"} eq "joe");
+
+ eval { grep { $h{$_} } (1, 2, 3) };
+ ok (! $@);
+
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ $h{"fred"} = "joe" ;
+
+ ok($h{"fred"} eq "joe");
+
+ ok($db->FIRSTKEY() eq "fred") ;
+
+ eval { grep { $h{$_} } (1, 2, 3) };
+ ok (! $@);
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+if(0)
+{
+ # Filter without tie
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok $db = tie %h, 'BerkeleyDB::Hash',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE;
+
+ my %result = () ;
+
+ sub INC { return ++ $_[0] }
+ sub DEC { return -- $_[0] }
+ #$db->filter_fetch_key (sub { warn "FFK $_\n"; $_ = INC($_); warn "XX\n" }) ;
+ #$db->filter_store_key (sub { warn "FSK $_\n"; $_ = DEC($_); warn "XX\n" }) ;
+ #$db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = INC($_); warn "XX\n"}) ;
+ #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = DEC($_); warn "XX\n" }) ;
+
+ $db->filter_fetch_key (sub { warn "FFK $_\n"; $_ = pack("i", $_); warn "XX\n" }) ;
+ $db->filter_store_key (sub { warn "FSK $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ;
+ $db->filter_fetch_value (sub { warn "FFV $_\n"; $_ = pack("i", $_); warn "XX\n"}) ;
+ #$db->filter_store_value (sub { warn "FSV $_\n"; $_ = unpack("i", $_); warn "XX\n" }) ;
+
+ #$db->filter_fetch_key (sub { ++ $_ }) ;
+ #$db->filter_store_key (sub { -- $_ }) ;
+ #$db->filter_fetch_value (sub { ++ $_ }) ;
+ #$db->filter_store_value (sub { -- $_ }) ;
+
+ my ($k, $v) = (0,0);
+ ok ! $db->db_put(3,5);
+ exit;
+ ok ! $db->db_get(3, $v);
+ ok $v == 5 ;
+
+ $h{4} = 7 ;
+ ok $h{4} == 7;
+
+ $k = 10;
+ $v = 30;
+ $h{$k} = $v ;
+ ok $k == 10;
+ ok $v == 30;
+ ok $h{$k} == 30;
+
+ $k = 3;
+ ok ! $db->db_get($k, $v, DB_GET_BOTH);
+ ok $k == 3 ;
+ ok $v == 5 ;
+
+ my $cursor = $db->db_cursor();
+
+ my %tmp = ();
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ {
+ $tmp{$k} = $v;
+ }
+
+ ok keys %tmp == 3 ;
+ ok $tmp{3} == 5;
+
+ undef $cursor ;
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
diff --git a/lang/perl/BerkeleyDB/t/hash.t b/lang/perl/BerkeleyDB/t/hash.t
new file mode 100644
index 00000000..875db12a
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/hash.t
@@ -0,0 +1,732 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+plan tests => 216;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Hash -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ;
+ ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to HASH
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ is $db->Env, undef;
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->status() == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_put("key", "value") == 0 ;
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+ ok $db->db_del("some key") == 0 ;
+ ok (($status = $db->db_get("some key", $value)) == DB_NOTFOUND) ;
+ ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok $db->status() == DB_NOTFOUND ;
+ ok $db->status() =~ $DB_errors{'DB_NOTFOUND'};
+
+ ok $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEXIST'};
+ ok $db->status() == DB_KEYEXIST ;
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+
+ # test DB_GET_BOTH
+ my ($k, $v) = ("key", "value") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("key", "fred") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("another", "value") ;
+ ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+
+}
+
+{
+ # Check simple env works with a hash.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE| DB_INIT_MPOOL,@StdErrFile,
+ -Home => $home ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ isa_ok $db->Env, 'BerkeleyDB::Env';
+
+ # Add a k/v pair
+ my $value ;
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # override default hash
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ $::count = 0 ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Hash => sub { ++$::count ; length $_[0] },
+ -Flags => DB_CREATE ;
+
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $::count > 0 ;
+
+}
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => 2,
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # create the cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ $k = $v = "" ;
+ my %copy = %data ;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $status == DB_NOTFOUND ;
+ ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok $cursor->status() == $status ;
+ ok $cursor->status() eq $status ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ ($k, $v) = ("green", "house") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
+
+ ($k, $v) = ("green", "door") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+ ($k, $v) = ("black", "house") ;
+ ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
+
+}
+
+{
+ # Tied Hash interface
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # check "each" with an empty database
+ my $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ ++ $count ;
+ }
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok $count == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $hash{"some key"} = "some value";
+ ok ((tied %hash)->status() == 0) ;
+ ok $hash{"some key"} eq "some value";
+ ok defined $hash{"some key"} ;
+ ok ((tied %hash)->status() == 0) ;
+ ok exists $hash{"some key"} ;
+ ok !defined $hash{"jimmy"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok !exists $hash{"jimmy"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+
+ delete $hash{"some key"} ;
+ ok ((tied %hash)->status() == 0) ;
+ ok ! defined $hash{"some key"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+ ok ! exists $hash{"some key"} ;
+ ok ((tied %hash)->status() == DB_NOTFOUND) ;
+
+ $hash{1} = 2 ;
+ $hash{10} = 20 ;
+ $hash{1000} = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ while (my ($k, $v) = each %hash) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ ok $keys == 1011 ;
+ ok $values == 2022 ;
+
+ # now clear the hash
+ %hash = () ;
+ ok keys %hash == 0 ;
+
+ untie %hash ;
+}
+
+{
+ # in-memory file
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $fd ;
+ my $value ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash'
+ or die $BerkeleyDB::Error;
+
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+
+ undef $db ;
+ untie %hash ;
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+
+ # do a partial get
+ my($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok $pon == 0 && $off == 0 && $len == 0 ;
+ ok (( $db->db_get("red", $value) == 0) && $value eq "bo") ;
+ ok (( $db->db_get("green", $value) == 0) && $value eq "ho") ;
+ ok (( $db->db_get("blue", $value) == 0) && $value eq "se") ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "t" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "se" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 3 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "boat" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "house" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok ! $pon ;
+ ok $off == 0 ;
+ ok $len == 0 ;
+ ok $db->db_put("red", "") == 0 ;
+ ok $db->db_put("green", "AB") == 0 ;
+ ok $db->db_put("blue", "XYZ") == 0 ;
+ ok $db->db_put("new", "KLM") == 0 ;
+
+ $db->partial_clear() ;
+ ok $db->db_get("red", $value) == 0 && $value eq "at" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
+ ok $db->db_get("new", $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok $db->db_put("red", "PPP") == 0 ;
+ ok $db->db_put("green", "Q") == 0 ;
+ ok $db->db_put("blue", "XYZ") == 0 ;
+ ok $db->db_put("new", "--") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 3 ;
+ ok $len == 2 ;
+ ok $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
+ ok $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
+ ok $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
+ ok $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
+}
+
+{
+ # partial
+ # check works via tied hash
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ while (my ($k, $v) = each %data) {
+ $hash{$k} = $v ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok $hash{"red"} eq "bo" ;
+ ok $hash{"green"} eq "ho" ;
+ ok $hash{"blue"} eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok $hash{"red"} eq "t" ;
+ ok $hash{"green"} eq "se" ;
+ ok $hash{"blue"} eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "boat" ;
+ ok $hash{"green"} eq "house" ;
+ ok $hash{"blue"} eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $hash{"red"} = "" ;
+ ok $hash{"green"} = "AB" ;
+ ok $hash{"blue"} = "XYZ" ;
+ ok $hash{"new"} = "KLM" ;
+
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "at" ;
+ ok $hash{"green"} eq "ABuse" ;
+ ok $hash{"blue"} eq "XYZa" ;
+ ok $hash{"new"} eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok $hash{"red"} = "PPP" ;
+ ok $hash{"green"} = "Q" ;
+ ok $hash{"blue"} = "XYZ" ;
+ ok $hash{"new"} = "TU" ;
+
+ $db->partial_clear() ;
+ ok $hash{"red"} eq "at\0PPP" ;
+ ok $hash{"green"} eq "ABuQ" ;
+ ok $hash{"blue"} eq "XYZXYZ" ;
+ ok $hash{"new"} eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ isa_ok((tied %hash)->Env, 'BerkeleyDB::Env');
+ (tied %hash)->Env->errPrefix("abc");
+ is((tied %hash)->Env->errPrefix("abc"), 'abc');
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+
+{
+ # DB_DUP
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hash{'Wall'} = 'Larry' ;
+ $hash{'Wall'} = 'Stone' ;
+ $hash{'Smith'} = 'John' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'Wall'} = 'Brick' ;
+ $hash{'mouse'} = 'mickey' ;
+
+ ok keys %hash == 6 ;
+
+ # create a cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ my $key = "Wall" ;
+ my $value ;
+ ok $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok $key eq "Wall" && $value eq "Larry" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Stone" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Brick" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key eq "Wall" && $value eq "Brick" ;
+
+ #my $ref = $db->db_stat() ;
+ #ok $ref->{bt_flags} | DB_DUP ;
+
+ # test DB_DUP_NEXT
+ my ($k, $v) = ("Wall", "") ;
+ ok $cursor->c_get($k, $v, DB_SET) == 0 ;
+ ok $k eq "Wall" && $v eq "Larry" ;
+ ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok $k eq "Wall" && $v eq "Stone" ;
+ ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok $k eq "Wall" && $v eq "Brick" ;
+ ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
+ ok $k eq "Wall" && $v eq "Brick" ;
+ ok $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
+
+
+ undef $db ;
+ undef $cursor ;
+ untie %hash ;
+
+}
+
+{
+ # DB_DUP & DupCompare
+ my $lex = new LexFile $Dfile, $Dfile2;
+ my ($key, $value) ;
+ my (%h, %g) ;
+ my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
+ my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
+
+ ok tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Flags => DB_CREATE ;
+
+ ok tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
+ -DupCompare => sub { $_[0] <=> $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Flags => DB_CREATE ;
+
+ foreach (@Keys) {
+ local $^W = 0 ;
+ my $value = shift @Values ;
+ $h{$_} = $value ;
+ $g{$_} = $value ;
+ }
+
+ ok my $cursor = (tied %h)->db_cursor() ;
+ $key = 9 ; $value = "";
+ ok $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok $key == 9 && $value eq 11 ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key == 9 && $value == 2 ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key == 9 && $value eq "x" ;
+
+ $cursor = (tied %g)->db_cursor() ;
+ $key = 9 ;
+ ok $cursor->c_get($key, $value, DB_SET) == 0 ;
+ ok $key == 9 && $value eq "x" ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key == 9 && $value == 2 ;
+ ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
+ ok $key == 9 && $value == 11 ;
+
+
+}
+
+{
+ # get_dup etc
+ my $lex = new LexFile $Dfile;
+ my %hh ;
+
+ ok my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP,
+ -Flags => DB_CREATE ;
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $hh{'Smith'} = 'John' ;
+ $hh{'mouse'} = 'mickey' ;
+
+ # first work in scalar context
+ ok scalar $YY->get_dup('Unknown') == 0 ;
+ ok scalar $YY->get_dup('Smith') == 1 ;
+ ok scalar $YY->get_dup('Wall') == 3 ;
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ ok "@unknown" eq "" ;
+
+ my @smith = $YY->get_dup('Smith') ;
+ ok "@smith" eq "John" ;
+
+ {
+ my @wall = $YY->get_dup('Wall') ;
+ my %wall ;
+ @wall{@wall} = @wall ;
+ ok (@wall == 3 && $wall{'Larry'}
+ && $wall{'Stone'} && $wall{'Brick'});
+ }
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ ok keys %unknown == 0 ;
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ ok keys %smith == 1 && $smith{'John'} ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 1 ;
+
+ undef $YY ;
+ untie %hh ;
+
+}
+
+{
+ # 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 BerkeleyDB;
+ @ISA=qw(BerkeleyDB BerkeleyDB::Hash);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_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 ;
+
+ use Test::More;
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ ok $@ eq "" ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB", -Filename => "dbhash.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ ok $@ eq "" ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ ok $@ eq "" ;
+ ok $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
+ ok $@ eq "" ;
+ ok $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ ok $@ eq "" ;
+ ok $ret == 1 ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ ok $@ eq "" ;
+ ok $ret eq "[[10]]" ;
+
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
diff --git a/lang/perl/BerkeleyDB/t/join.t b/lang/perl/BerkeleyDB/t/join.t
new file mode 100644
index 00000000..a4152c79
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/join.t
@@ -0,0 +1,235 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't';
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+BEGIN {
+ plan(skip_all => "this needs BerkeleyDB 2.5.2 or better" )
+ if $BerkeleyDB::db_ver < 2.005002;
+
+ plan tests => 42;
+}
+
+my $Dfile1 = "dbhash1.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+umask(0) ;
+
+{
+ # error cases
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash1 ;
+ my $value ;
+ my $status ;
+ my $cursor ;
+
+ ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
+ -Filename => $Dfile1,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] lt $_[1] },
+ -Property => DB_DUP|DB_DUPSORT ;
+
+ # no cursors supplied
+ eval '$cursor = $db1->db_join() ;' ;
+ ok $@ =~ /Usage: \$db->BerkeleyDB::db_join\Q([cursors], flags=0)/;
+
+ # empty list
+ eval '$cursor = $db1->db_join([]) ;' ;
+ ok $@ =~ /db_join: No cursors in parameter list/;
+
+ # cursor list, isn not a []
+ eval '$cursor = $db1->db_join({}) ;' ;
+ ok $@ =~ /db_join: first parameter is not an array reference/;
+
+ eval '$cursor = $db1->db_join(\1) ;' ;
+ ok $@ =~ /db_join: first parameter is not an array reference/;
+
+ my ($a, $b) = ("a", "b");
+ $a = bless [], "fred";
+ $b = bless [], "fred";
+ eval '$cursor = $db1->db_join($a, $b) ;' ;
+ ok $@ =~ /db_join: first parameter is not an array reference/;
+
+}
+
+{
+ # test a 2-way & 3-way join
+
+ my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
+ my %hash1 ;
+ my %hash2 ;
+ my %hash3 ;
+ my $value ;
+ my $status ;
+
+ my $home = "./fred7" ;
+ rmtree $home;
+ ok ! -d $home;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN
+ |DB_INIT_MPOOL;
+ #|DB_INIT_MPOOL| DB_INIT_LOCK;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
+ -Filename => $Dfile1,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+ ;
+
+ ok my $db2 = tie %hash2, 'BerkeleyDB::Hash',
+ -Filename => $Dfile2,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok my $db3 = tie %hash3, 'BerkeleyDB::Btree',
+ -Filename => $Dfile3,
+ -Flags => DB_CREATE,
+ -DupCompare => sub { $_[0] cmp $_[1] },
+ -Property => DB_DUP|DB_DUPSORT,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok addData($db1, qw( apple Convenience
+ peach Shopway
+ pear Farmer
+ raspberry Shopway
+ strawberry Shopway
+ gooseberry Farmer
+ blueberry Farmer
+ ));
+
+ ok addData($db2, qw( red apple
+ red raspberry
+ red strawberry
+ yellow peach
+ yellow pear
+ green gooseberry
+ blue blueberry)) ;
+
+ ok addData($db3, qw( expensive apple
+ reasonable raspberry
+ expensive strawberry
+ reasonable peach
+ reasonable pear
+ expensive gooseberry
+ reasonable blueberry)) ;
+
+ ok my $cursor2 = $db2->db_cursor() ;
+ my $k = "red" ;
+ my $v = "" ;
+ ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ # Two way Join
+ ok my $cursor1 = $db1->db_join([$cursor2]) ;
+
+ my %expected = qw( apple Convenience
+ raspberry Shopway
+ strawberry Shopway
+ ) ;
+
+ # sequence forwards
+ while ($cursor1->c_get($k, $v) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} && $expected{$k} eq $v ;
+ #print "[$k] [$v]\n" ;
+ }
+ is keys %expected, 0 ;
+ ok $cursor1->status() == DB_NOTFOUND ;
+
+ # Three way Join
+ ok $cursor2 = $db2->db_cursor() ;
+ $k = "red" ;
+ $v = "" ;
+ ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ ok my $cursor3 = $db3->db_cursor() ;
+ $k = "expensive" ;
+ $v = "" ;
+ ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
+ ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
+
+ %expected = qw( apple Convenience
+ strawberry Shopway
+ ) ;
+
+ # sequence forwards
+ while ($cursor1->c_get($k, $v) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} && $expected{$k} eq $v ;
+ #print "[$k] [$v]\n" ;
+ }
+ is keys %expected, 0 ;
+ ok $cursor1->status() == DB_NOTFOUND ;
+
+ # test DB_JOIN_ITEM
+ # #################
+ ok $cursor2 = $db2->db_cursor() ;
+ $k = "red" ;
+ $v = "" ;
+ ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
+
+ ok $cursor3 = $db3->db_cursor() ;
+ $k = "expensive" ;
+ $v = "" ;
+ ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
+ ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
+
+ %expected = qw( apple 1
+ strawberry 1
+ ) ;
+
+ # sequence forwards
+ $k = "" ;
+ $v = "" ;
+ while ($cursor1->c_get($k, $v, DB_JOIN_ITEM) == 0) {
+ delete $expected{$k}
+ if defined $expected{$k} ;
+ #print "[$k]\n" ;
+ }
+ is keys %expected, 0 ;
+ ok $cursor1->status() == DB_NOTFOUND ;
+
+ ok $cursor1->c_close() == 0 ;
+ ok $cursor2->c_close() == 0 ;
+ ok $cursor3->c_close() == 0 ;
+
+ ok (($status = $txn->txn_commit()) == 0);
+
+ undef $txn ;
+
+ ok my $cursor1a = $db1->db_cursor() ;
+ eval { $cursor1 = $db1->db_join([$cursor1a]) };
+ ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
+ eval { $cursor1 = $db1->db_join([$cursor1]) } ;
+ ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
+
+ undef $cursor1a;
+ #undef $cursor1;
+ #undef $cursor2;
+ #undef $cursor3;
+ undef $db1 ;
+ undef $db2 ;
+ undef $db3 ;
+ undef $env ;
+ untie %hash1 ;
+ untie %hash2 ;
+ untie %hash3 ;
+}
+
+print "# at the end\n";
diff --git a/lang/perl/BerkeleyDB/t/mldbm.t b/lang/perl/BerkeleyDB/t/mldbm.t
new file mode 100644
index 00000000..4c50d192
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/mldbm.t
@@ -0,0 +1,110 @@
+#!/usr/bin/perl -w
+
+use strict ;
+
+use lib 't';
+use Test::More ;
+
+BEGIN
+{
+ plan skip_all => "this is Perl $], skipping test\n"
+ if $] < 5.005 ;
+
+ eval { require Data::Dumper ; };
+ if ($@) {
+ plan skip_all => "Data::Dumper is not installed on this system.\n";
+ }
+ {
+ local ($^W) = 0 ;
+ if ($Data::Dumper::VERSION < 2.08) {
+ plan skip_all => "Data::Dumper 2.08 or better required (found $Data::Dumper::VERSION).\n";
+ }
+ }
+ eval { require MLDBM ; };
+ if ($@) {
+ plan skip_all => "MLDBM is not installed on this system.\n";
+ }
+
+ plan tests => 12;
+}
+
+use lib 't' ;
+use util ;
+
+{
+ package BTREE ;
+
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Btree) ;
+ use Data::Dumper;
+ use Test::More;
+
+ my $filename = "";
+ my $lex = new LexFile $filename;
+
+ $MLDBM::UseDB = "BerkeleyDB::Btree" ;
+ my %o ;
+ my $db = tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die $!;
+ ok $db ;
+ ok $db->type() == DB_BTREE ;
+
+ my $c = [\'c'];
+ my $b = {};
+ my $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ @o{qw(a b c)} = ($a, $b, $c);
+ $o{d} = "{once upon a time}";
+ $o{e} = 1024;
+ $o{f} = 1024.1024;
+
+ my $struct = [@o{qw(a b c)}];
+ ok ::_compare([$a, $b, $c], $struct);
+ ok $o{d} eq "{once upon a time}" ;
+ ok $o{e} == 1024 ;
+ ok $o{f} eq 1024.1024 ;
+
+}
+
+{
+
+ package HASH ;
+
+ use BerkeleyDB ;
+ use MLDBM qw(BerkeleyDB::Hash) ;
+ use Data::Dumper;
+
+ my $filename = "";
+ my $lex = new LexFile $filename;
+
+ unlink $filename ;
+ $MLDBM::UseDB = "BerkeleyDB::Hash" ;
+ my %o ;
+ my $db = tie %o, 'MLDBM', -Filename => $filename,
+ -Flags => DB_CREATE
+ or die $!;
+ ::ok $db ;
+ ::ok $db->type() == DB_HASH ;
+
+
+ my $c = [\'c'];
+ my $b = {};
+ my $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ @o{qw(a b c)} = ($a, $b, $c);
+ $o{d} = "{once upon a time}";
+ $o{e} = 1024;
+ $o{f} = 1024.1024;
+
+ my $struct = [@o{qw(a b c)}];
+ ::ok ::_compare([$a, $b, $c], $struct);
+ ::ok $o{d} eq "{once upon a time}" ;
+ ::ok $o{e} == 1024 ;
+ ::ok $o{f} eq 1024.1024 ;
+
+}
diff --git a/lang/perl/BerkeleyDB/t/pod.t b/lang/perl/BerkeleyDB/t/pod.t
new file mode 100644
index 00000000..230df4bd
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/pod.t
@@ -0,0 +1,18 @@
+eval " use Test::More " ;
+
+if ($@)
+{
+ print "1..0 # Skip: Test::More required for testing POD\n" ;
+ exit 0;
+}
+
+eval "use Test::Pod 1.00";
+
+if ($@)
+{
+ print "1..0 # Skip: Test::Pod 1.00 required for testing POD\n" ;
+ exit 0;
+}
+
+all_pod_files_ok();
+
diff --git a/lang/perl/BerkeleyDB/t/queue.t b/lang/perl/BerkeleyDB/t/queue.t
new file mode 100644
index 00000000..fd372ae7
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/queue.t
@@ -0,0 +1,875 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use Test::More;
+use util;
+
+plan(skip_all => "Queue needs Berkeley DB 3.3.x or better\n" )
+ if $BerkeleyDB::db_version < 3.3;
+
+plan tests => 257;
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Queue -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Queue -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) / ;
+
+ eval ' $db = new BerkeleyDB::Queue -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Queue -Txn => "x" ' ;
+ ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Queue -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Queue
+
+{
+ my $lex = new LexFile $Dfile ;
+ my $rec_len = 10 ;
+ my $pad = "x" ;
+
+ ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Len => $rec_len,
+ -Pad => $pad;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ is $db->Env, undef;
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->status() == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq fillout("some value", $rec_len, $pad) ;
+ ok $db->db_put(2, "value") == 0 ;
+ ok $db->db_get(2, $value) == 0 ;
+ ok $value eq fillout("value", $rec_len, $pad) ;
+ ok $db->db_put(3, "value") == 0 ;
+ ok $db->db_get(3, $value) == 0 ;
+ ok $value eq fillout("value", $rec_len, $pad) ;
+ ok $db->db_del(2) == 0 ;
+ ok $db->db_get(2, $value) == DB_KEYEMPTY ;
+ ok $db->status() == DB_KEYEMPTY ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEMPTY'} ;
+
+ ok $db->db_get(7, $value) == DB_NOTFOUND ;
+ ok $db->status() == DB_NOTFOUND ;
+ ok $db->status() =~ $DB_errors{'DB_NOTFOUND'} ;
+
+ ok $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok $db->db_put( 1, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEXIST'} ;
+ ok $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq fillout("some value", $rec_len, $pad) ;
+
+
+}
+
+
+{
+ # Check simple env works with a array.
+ # and pad defaults to space
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ my $rec_len = 11 ;
+ ok my $lexD = new LexDir($home);
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,@StdErrFile,
+ -Home => $home ;
+ ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE,
+ -Len => $rec_len;
+
+ isa_ok $db->Env, 'BerkeleyDB::Env';
+
+ # Add a k/v pair
+ my $value ;
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq fillout("some value", $rec_len) ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my ($k, $v) ;
+ my $rec_len = 5 ;
+ ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len;
+
+ # create some data
+ my @data = (
+ "red" ,
+ "green" ,
+ "blue" ,
+ ) ;
+
+ my $i ;
+ my %data ;
+ my $ret = 0 ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ $data{$i} = $data[$i] ;
+ }
+ ok $ret == 0 ;
+
+ # create the cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ $k = 0 ; $v = "" ;
+ my %copy = %data;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ {
+ if ( fillout($copy{$k}, $rec_len) eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( fillout($copy{$k}, $rec_len) eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $status == DB_NOTFOUND ;
+ ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok $cursor->status() == $status ;
+ ok $cursor->status() eq $status ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+}
+
+{
+ # Tied Array interface
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ my $rec_len = 10 ;
+ ok $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len;
+
+ ok my $cursor = (tied @array)->db_cursor() ;
+ # check the database is empty
+ my $count = 0 ;
+ my ($k, $v) = (0,"") ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $count == 0 ;
+
+ ok @array == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $array[1] = "some value";
+ ok ((tied @array)->status() == 0) ;
+ ok $array[1] eq fillout("some value", $rec_len);
+ ok defined $array[1];
+ ok ((tied @array)->status() == 0) ;
+ ok !defined $array[3];
+ ok ((tied @array)->status() == DB_NOTFOUND) ;
+
+ $array[1] = 2 ;
+ $array[10] = 20 ;
+ $array[100] = 200 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ ok $keys == 111 ;
+ ok $values == 222 ;
+
+ # unshift isn't allowed
+# eval {
+# $FA ? unshift @array, "red", "green", "blue"
+# : $db->unshift("red", "green", "blue" ) ;
+# } ;
+# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
+ $array[0] = "red" ;
+ $array[1] = "green" ;
+ $array[2] = "blue" ;
+ $array[4] = 2 ;
+ ok $array[0] eq fillout("red", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok $k == 0 ;
+ ok $v eq fillout("red", $rec_len) ;
+ ok $array[1] eq fillout("green", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 1 ;
+ ok $v eq fillout("green", $rec_len) ;
+ ok $array[2] eq fillout("blue", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 2 ;
+ ok $v eq fillout("blue", $rec_len) ;
+ ok $array[4] == 2 ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 4 ;
+ ok $v == 2 ;
+
+ # shift
+ ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) == 2) ;
+
+ # push
+ $FA ? push @array, "the", "end"
+ : $db->push("the", "end") ;
+ ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok $k == 102 ;
+ ok $v eq fillout("end", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 101 ;
+ ok $v eq fillout("the", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 100 ;
+ ok $v == 200 ;
+
+ # pop
+ ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
+ ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
+ ok (( $FA ? pop @array : $db->pop ) == 200) ;
+
+ undef $cursor;
+
+ # now clear the array
+ $FA ? @array = ()
+ : $db->clear() ;
+ ok $cursor = (tied @array)->db_cursor() ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
+
+ undef $cursor ;
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory file
+
+ my @array ;
+ my $fd ;
+ my $value ;
+ my $rec_len = 15 ;
+ ok my $db = tie @array, 'BerkeleyDB::Queue',
+ -Len => $rec_len;
+
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq fillout("some value", $rec_len) ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ my $rec_len = 8 ;
+ ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ my $r = $db->db_put($i, $data[$i]) ;
+ $ret += $r ;
+ }
+ ok $ret == 0 ;
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok ! $pon && $off == 0 && $len == 0 ;
+ ok $db->db_get(1, $value) == 0 && $value eq "bo" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "ho" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq fillout("t", 2) ;
+ ok $db->db_get(2, $value) == 0 && $value eq "se" ;
+ ok $db->db_get(3, $value) == 0 && $value eq " " ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 3 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
+ ok $db->db_get(2, $value) == 0 && $value eq fillout("house", $rec_len) ;
+ ok $db->db_get(3, $value) == 0 && $value eq fillout("sea", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $db->db_put(1, "") != 0 ;
+ ok $db->db_put(2, "AB") == 0 ;
+ ok $db->db_put(3, "XY") == 0 ;
+ ok $db->db_put(4, "KLM") != 0 ;
+ ok $db->db_put(4, "KL") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq fillout("boat", $rec_len) ;
+ ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse", $rec_len) ;
+ ok $db->db_get(3, $value) == 0 && $value eq fillout("XYa", $rec_len) ;
+ ok $db->db_get(4, $value) == 0 && $value eq fillout("KL", $rec_len) ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok ! $pon ;
+ ok $off == 0 ;
+ ok $len == 0 ;
+ ok $db->db_put(1, "PP") == 0 ;
+ ok $db->db_put(2, "Q") != 0 ;
+ ok $db->db_put(3, "XY") == 0 ;
+ ok $db->db_put(4, "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok $db->db_get(1, $value) == 0 && $value eq fillout("boaPP", $rec_len) ;
+ ok $db->db_get(2, $value) == 0 && $value eq fillout("ABuse",$rec_len) ;
+ ok $db->db_get(3, $value) == 0 && $value eq fillout("XYaXY", $rec_len) ;
+ ok $db->db_get(4, $value) == 0 && $value eq fillout("KL TU", $rec_len) ;
+}
+
+{
+ # partial
+ # check works via tied array
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+ my $rec_len = 8 ;
+ ok my $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $i ;
+ my $status = 0 ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $array[$i] = $data[$i] ;
+ $status += $db->status() ;
+ }
+
+ ok $status == 0 ;
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok $array[1] eq fillout("bo", 2) ;
+ ok $array[2] eq fillout("ho", 2) ;
+ ok $array[3] eq fillout("se", 2) ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok $array[1] eq fillout("t", 2) ;
+ ok $array[2] eq fillout("se", 2) ;
+ ok $array[3] eq fillout("", 2) ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok $array[1] eq fillout("boat", $rec_len) ;
+ ok $array[2] eq fillout("house", $rec_len) ;
+ ok $array[3] eq fillout("sea", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ $array[1] = "" ;
+ ok $db->status() != 0 ;
+ $array[2] = "AB" ;
+ ok $db->status() == 0 ;
+ $array[3] = "XY" ;
+ ok $db->status() == 0 ;
+ $array[4] = "KL" ;
+ ok $db->status() == 0 ;
+
+ $db->partial_clear() ;
+ ok $array[1] eq fillout("boat", $rec_len) ;
+ ok $array[2] eq fillout("ABuse", $rec_len) ;
+ ok $array[3] eq fillout("XYa", $rec_len) ;
+ ok $array[4] eq fillout("KL", $rec_len) ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ $array[1] = "PP" ;
+ ok $db->status() == 0 ;
+ $array[2] = "Q" ;
+ ok $db->status() != 0 ;
+ $array[3] = "XY" ;
+ ok $db->status() == 0 ;
+ $array[4] = "TU" ;
+ ok $db->status() == 0 ;
+
+ $db->partial_clear() ;
+ ok $array[1] eq fillout("boaPP", $rec_len) ;
+ ok $array[2] eq fillout("ABuse", $rec_len) ;
+ ok $array[3] eq fillout("XYaXY", $rec_len) ;
+ ok $array[4] eq fillout("KL TU", $rec_len) ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ my $rec_len = 9 ;
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie @array, 'BerkeleyDB::Queue',
+ -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my @data = (
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db1->db_put($i, $data[$i]) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = (0, "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie @array ;
+}
+
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "qs_ndata" : "qs_nrecs") ;
+ my @array ;
+ my ($k, $v) ;
+ my $rec_len = 7 ;
+ ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Pagesize => 4 * 1024,
+ -Len => $rec_len,
+ -Pad => " "
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 0;
+ ok $ref->{'qs_pagesize'} == 4 * 1024;
+
+ # create some data
+ my @data = (
+ 2,
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = $db->ArrayOffset ; @data ; ++$i) {
+ $ret += $db->db_put($i, shift @data) ;
+ }
+ ok $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 3;
+}
+
+{
+ # 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 BerkeleyDB;
+ @ISA=qw(BerkeleyDB BerkeleyDB::Queue);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_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 ;
+
+ use Test::More;
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ ok $@ eq "" ;
+ my @h ;
+ my $X ;
+ my $rec_len = 34 ;
+ eval '
+ $X = tie(@h, "SubDB", -Filename => "dbqueue.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 ,
+ -Len => $rec_len,
+ -Pad => " "
+ );
+ ' ;
+
+ ok $@ eq "" ;
+
+ my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
+ ok $@ eq "" ;
+ ok $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
+ ok $@ eq "" ;
+ ok $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ ok $@ eq "" ;
+ ok $ret == 1 ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ ok $@ eq "" ;
+ ok $ret eq "[[10]]" ;
+
+ undef $X ;
+ untie @h ;
+ unlink "SubDB.pm", "dbqueue.tmp" ;
+
+}
+
+{
+ # DB_APPEND
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ my $rec_len = 21 ;
+ ok my $db = tie @array, 'BerkeleyDB::Queue',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Len => $rec_len,
+ -Pad => " " ;
+
+ # create a few records
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ my $k = 0 ;
+ ok $db->db_put($k, "fred", DB_APPEND) == 0 ;
+ ok $k == 4 ;
+ ok $array[4] eq fillout("fred", $rec_len) ;
+
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # 23 Sept 2001 -- push into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ my $rec_len = 21 ;
+ ok $db = tie @array, 'BerkeleyDB::Queue',
+ -Flags => DB_CREATE ,
+ -ArrayBase => 0,
+ -Len => $rec_len,
+ -Pad => " " ,
+ -Filename => $Dfile ;
+ $FA ? push @array, "first"
+ : $db->push("first") ;
+
+ ok (($FA ? pop @array : $db->pop()) eq fillout("first", $rec_len)) ;
+
+ undef $db;
+ untie @array ;
+
+}
+
+{
+ # Tied Array interface with transactions
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ my $rec_len = 10 ;
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Env => $env ,
+ -Txn => $txn ,
+ -Len => $rec_len;
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db->Txn($txn);
+
+ ok my $cursor = (tied @array)->db_cursor() ;
+ # check the database is empty
+ my $count = 0 ;
+ my ($k, $v) = (0,"") ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $count == 0 ;
+
+ ok @array == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $array[1] = "some value";
+ ok ((tied @array)->status() == 0) ;
+ ok $array[1] eq fillout("some value", $rec_len);
+ ok defined $array[1];
+ ok ((tied @array)->status() == 0) ;
+ ok !defined $array[3];
+ ok ((tied @array)->status() == DB_NOTFOUND) ;
+
+ $array[1] = 2 ;
+ $array[10] = 20 ;
+ $array[100] = 200 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ ok $keys == 111 ;
+ ok $values == 222 ;
+
+ # unshift isn't allowed
+# eval {
+# $FA ? unshift @array, "red", "green", "blue"
+# : $db->unshift("red", "green", "blue" ) ;
+# } ;
+# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
+ $array[0] = "red" ;
+ $array[1] = "green" ;
+ $array[2] = "blue" ;
+ $array[4] = 2 ;
+ ok $array[0] eq fillout("red", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok $k == 0 ;
+ ok $v eq fillout("red", $rec_len) ;
+ ok $array[1] eq fillout("green", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 1 ;
+ ok $v eq fillout("green", $rec_len) ;
+ ok $array[2] eq fillout("blue", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 2 ;
+ ok $v eq fillout("blue", $rec_len) ;
+ ok $array[4] == 2 ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 4 ;
+ ok $v == 2 ;
+
+ # shift
+ ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
+ ok (($FA ? shift @array : $db->shift()) == 2) ;
+
+ # push
+ $FA ? push @array, "the", "end"
+ : $db->push("the", "end") ;
+ ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok $k == 102 ;
+ ok $v eq fillout("end", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 101 ;
+ ok $v eq fillout("the", $rec_len) ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 100 ;
+ ok $v == 200 ;
+
+ # pop
+ ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
+ ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
+ ok (( $FA ? pop @array : $db->pop ) == 200 ) ;
+
+ undef $cursor ;
+ # now clear the array
+ $FA ? @array = ()
+ : $db->clear() ;
+ ok $cursor = (tied @array)->db_cursor() ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
+ undef $cursor ;
+ ok $txn->txn_commit() == 0 ;
+
+ undef $db ;
+ untie @array ;
+}
+__END__
+
+
+# TODO
+#
+# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
diff --git a/lang/perl/BerkeleyDB/t/recno.t b/lang/perl/BerkeleyDB/t/recno.t
new file mode 100644
index 00000000..fad7829e
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/recno.t
@@ -0,0 +1,915 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+
+plan tests => 228;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) / ;
+
+ eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ;
+ ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# Now check the interface to Recno
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ is $db->Env, undef;
+
+ # Add a k/v pair
+ my $value ;
+ my $status ;
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->status() == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_put(2, "value") == 0 ;
+ ok $db->db_get(2, $value) == 0 ;
+ ok $value eq "value" ;
+ ok $db->db_del(1) == 0 ;
+ ok (($status = $db->db_get(1, $value)) == DB_KEYEMPTY) ;
+ ok $db->status() == DB_KEYEMPTY ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEMPTY'} ;
+
+ ok (($status = $db->db_get(7, $value)) == DB_NOTFOUND) ;
+ ok $db->status() == DB_NOTFOUND ;
+ ok $db->status() =~ $DB_errors{'DB_NOTFOUND'} ;
+
+ ok $db->db_sync() == 0 ;
+
+ # Check NOOVERWRITE will make put fail when attempting to overwrite
+ # an existing record.
+
+ ok $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
+ ok $db->status() =~ $DB_errors{'DB_KEYEXIST'} ;
+ ok $db->status() == DB_KEYEXIST ;
+
+
+ # check that the value of the key has not been changed by the
+ # previous test
+ ok $db->db_get(2, $value) == 0 ;
+ ok $value eq "value" ;
+
+
+}
+
+
+{
+ # Check simple env works with a array.
+ my $lex = new LexFile $Dfile ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+
+ ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE|DB_INIT_MPOOL,@StdErrFile,
+ -Home => $home ;
+
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Env => $env,
+ -Flags => DB_CREATE ;
+
+ isa_ok $db->Env, 'BerkeleyDB::Env';
+
+ # Add a k/v pair
+ my $value ;
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq "some value" ;
+ undef $db ;
+ undef $env ;
+}
+
+
+{
+ # cursors
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "red" ,
+ "green" ,
+ "blue" ,
+ ) ;
+
+ my $i ;
+ my %data ;
+ my $ret = 0 ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ $data{$i} = $data[$i] ;
+ }
+ ok $ret == 0 ;
+
+ # create the cursor
+ ok my $cursor = $db->db_cursor() ;
+
+ $k = 0 ; $v = "" ;
+ my %copy = %data;
+ my $extras = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+
+ # sequence backwards
+ %copy = %data ;
+ $extras = 0 ;
+ my $status ;
+ for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_PREV)) {
+ if ( $copy{$k} eq $v )
+ { delete $copy{$k} }
+ else
+ { ++ $extras }
+ }
+ ok $status == DB_NOTFOUND ;
+ ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
+ ok $cursor->status() == $status ;
+ ok $cursor->status() eq $status ;
+ ok keys %copy == 0 ;
+ ok $extras == 0 ;
+}
+
+{
+ # Tied Array interface
+
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Property => DB_RENUMBER,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+
+ ok my $cursor = ((tied @array)->db_cursor()) ;
+ # check the database is empty
+ my $count = 0 ;
+ my ($k, $v) = (0,"") ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $cursor->status() == DB_NOTFOUND ;
+ ok $count == 0 ;
+
+ ok @array == 0 ;
+
+ # Add a k/v pair
+ my $value ;
+ $array[1] = "some value";
+ ok ((tied @array)->status() == 0) ;
+ ok $array[1] eq "some value";
+ ok defined $array[1];
+ ok ((tied @array)->status() == 0) ;
+ ok !defined $array[3];
+ ok ((tied @array)->status() == DB_NOTFOUND) ;
+
+ ok ((tied @array)->db_del(1) == 0) ;
+ ok ((tied @array)->status() == 0) ;
+ ok ! defined $array[1];
+ ok ((tied @array)->status() == DB_NOTFOUND) ;
+
+ $array[1] = 2 ;
+ $array[10] = 20 ;
+ $array[1000] = 2000 ;
+
+ my ($keys, $values) = (0,0);
+ $count = 0 ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ $keys += $k ;
+ $values += $v ;
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ ok $keys == 1011 ;
+ ok $values == 2022 ;
+
+ # unshift
+ $FA ? unshift @array, "red", "green", "blue"
+ : $db->unshift("red", "green", "blue" ) ;
+ ok $array[1] eq "red" ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
+ ok $k == 1 ;
+ ok $v eq "red" ;
+ ok $array[2] eq "green" ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 2 ;
+ ok $v eq "green" ;
+ ok $array[3] eq "blue" ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 3 ;
+ ok $v eq "blue" ;
+ ok $array[4] == 2 ;
+ ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
+ ok $k == 4 ;
+ ok $v == 2 ;
+
+ # shift
+ ok (($FA ? shift @array : $db->shift()) eq "red") ;
+ ok (($FA ? shift @array : $db->shift()) eq "green") ;
+ ok (($FA ? shift @array : $db->shift()) eq "blue") ;
+ ok (($FA ? shift @array : $db->shift()) == 2) ;
+
+ # push
+ $FA ? push @array, "the", "end"
+ : $db->push("the", "end") ;
+ ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
+ ok $k == 1001 ;
+ ok $v eq "end" ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 1000 ;
+ ok $v eq "the" ;
+ ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
+ ok $k == 999 ;
+ ok $v == 2000 ;
+
+ # pop
+ ok (( $FA ? pop @array : $db->pop ) eq "end") ;
+ ok (( $FA ? pop @array : $db->pop ) eq "the") ;
+ ok (( $FA ? pop @array : $db->pop ) == 2000) ;
+
+ undef $cursor;
+ # now clear the array
+ $FA ? @array = ()
+ : $db->clear() ;
+ ok $cursor = $db->db_cursor() ;
+ ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
+
+ undef $cursor ;
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory file
+
+ my @array ;
+ my $fd ;
+ my $value ;
+ ok my $db = tie @array, 'BerkeleyDB::Recno' ;
+
+ ok $db->db_put(1, "some value") == 0 ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq "some value" ;
+
+}
+
+{
+ # partial
+ # check works via API
+
+ my $lex = new LexFile $Dfile ;
+ my $value ;
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $ret += $db->db_put($i, $data[$i]) ;
+ }
+ ok $ret == 0 ;
+
+
+ # do a partial get
+ my ($pon, $off, $len) = $db->partial_set(0,2) ;
+ ok ! $pon && $off == 0 && $len == 0 ;
+ ok $db->db_get(1, $value) == 0 && $value eq "bo" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "ho" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "se" ;
+
+ # do a partial get, off end of data
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq "t" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "se" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "" ;
+
+ # switch of partial mode
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 3 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq "boat" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "house" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $db->db_put(1, "") == 0 ;
+ ok $db->db_put(2, "AB") == 0 ;
+ ok $db->db_put(3, "XYZ") == 0 ;
+ ok $db->db_put(4, "KLM") == 0 ;
+
+ ($pon, $off, $len) = $db->partial_clear() ;
+ ok $pon ;
+ ok $off == 0 ;
+ ok $len == 2 ;
+ ok $db->db_get(1, $value) == 0 && $value eq "at" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
+ ok $db->db_get(4, $value) == 0 && $value eq "KLM" ;
+
+ # now partial put
+ ($pon, $off, $len) = $db->partial_set(3,2) ;
+ ok ! $pon ;
+ ok $off == 0 ;
+ ok $len == 0 ;
+ ok $db->db_put(1, "PPP") == 0 ;
+ ok $db->db_put(2, "Q") == 0 ;
+ ok $db->db_put(3, "XYZ") == 0 ;
+ ok $db->db_put(4, "TU") == 0 ;
+
+ $db->partial_clear() ;
+ ok $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
+ ok $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
+ ok $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
+ ok $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
+}
+
+{
+ # partial
+ # check works via tied array
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+ ok my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create some data
+ my @data = (
+ "",
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $i ;
+ for ($i = 1 ; $i < @data ; ++$i) {
+ $array[$i] = $data[$i] ;
+ }
+
+
+ # do a partial get
+ $db->partial_set(0,2) ;
+ ok $array[1] eq "bo" ;
+ ok $array[2] eq "ho" ;
+ ok $array[3] eq "se" ;
+
+ # do a partial get, off end of data
+ $db->partial_set(3,2) ;
+ ok $array[1] eq "t" ;
+ ok $array[2] eq "se" ;
+ ok $array[3] eq "" ;
+
+ # switch of partial mode
+ $db->partial_clear() ;
+ ok $array[1] eq "boat" ;
+ ok $array[2] eq "house" ;
+ ok $array[3] eq "sea" ;
+
+ # now partial put
+ $db->partial_set(0,2) ;
+ ok $array[1] = "" ;
+ ok $array[2] = "AB" ;
+ ok $array[3] = "XYZ" ;
+ ok $array[4] = "KLM" ;
+
+ $db->partial_clear() ;
+ ok $array[1] eq "at" ;
+ ok $array[2] eq "ABuse" ;
+ ok $array[3] eq "XYZa" ;
+ ok $array[4] eq "KLM" ;
+
+ # now partial put
+ $db->partial_set(3,2) ;
+ ok $array[1] = "PPP" ;
+ ok $array[2] = "Q" ;
+ ok $array[3] = "XYZ" ;
+ ok $array[4] = "TU" ;
+
+ $db->partial_clear() ;
+ ok $array[1] eq "at\0PPP" ;
+ ok $array[2] eq "ABuQ" ;
+ ok $array[3] eq "XYZXYZ" ;
+ ok $array[4] eq "KLMTU" ;
+}
+
+{
+ # transaction
+
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie @array, 'BerkeleyDB::Recno',
+ -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my @data = (
+ "boat",
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = 0 ; $i < @data ; ++$i) {
+ $ret += $db1->db_put($i, $data[$i]) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = (0, "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie @array ;
+}
+
+
+{
+ # db_stat
+
+ my $lex = new LexFile $Dfile ;
+ my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
+ my @array ;
+ my ($k, $v) ;
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE,
+ -Pagesize => 4 * 1024,
+ ;
+
+ my $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 0;
+ ok $ref->{'bt_pagesize'} == 4 * 1024;
+
+ # create some data
+ my @data = (
+ 2,
+ "house",
+ "sea",
+ ) ;
+
+ my $ret = 0 ;
+ my $i ;
+ for ($i = $db->ArrayOffset ; @data ; ++$i) {
+ $ret += $db->db_put($i, shift @data) ;
+ }
+ ok $ret == 0 ;
+
+ $ref = $db->db_stat() ;
+ ok $ref->{$recs} == 3;
+}
+
+{
+ # 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 BerkeleyDB;
+ @ISA=qw(BerkeleyDB BerkeleyDB::Recno);
+ @EXPORT = @BerkeleyDB::EXPORT ;
+
+ sub db_put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::db_put($key, $value * 3) ;
+ }
+
+ sub db_get {
+ my $self = shift ;
+ $self->SUPER::db_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, '.'; }
+ use Test::More;
+ eval 'use SubDB ; ';
+ ok $@ eq "" ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB", -Filename => "dbrecno.tmp",
+ -Flags => DB_CREATE,
+ -Mode => 0640 );
+ ' ;
+
+ ok $@ eq "" ;
+
+ my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
+ ok $@ eq "" ;
+ ok $ret == 7 ;
+
+ my $value = 0;
+ $ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
+ ok $@ eq "" ;
+ ok $ret == 10 ;
+
+ $ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
+ ok $@ eq "" ;
+ ok $ret == 1 ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ ok $@ eq "" ;
+ ok $ret eq "[[10]]" ;
+
+ undef $X;
+ untie @h;
+ unlink "SubDB.pm", "dbrecno.tmp" ;
+
+}
+
+{
+ # variable length records, DB_DELIMETER -- defaults to \n
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc\ndef\n\nghi\n" ;
+}
+
+{
+ # variable length records, change DB_DELIMETER
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ,
+ -Delim => "-";
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc-def--ghi-";
+}
+
+{
+ # fixed length records, default DB_PAD
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => 5,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc def ghi " ;
+}
+
+{
+ # fixed length records, change Pad
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Len => 5,
+ -Pad => "-",
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc--def-------ghi--" ;
+}
+
+{
+ # DB_RENUMBER
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ ok my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
+ -Property => DB_RENUMBER,
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ;
+ # create a few records
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ ok my ($length, $joined) = joiner($db, "|") ;
+ ok $length == 3 ;
+ ok $joined eq "abc|def|ghi";
+
+ ok $db->db_del(1) == 0 ;
+ ($length, $joined) = joiner($db, "|") ;
+ ok $length == 2 ;
+ ok $joined eq "abc|ghi";
+
+ undef $db ;
+ untie @array ;
+
+}
+
+{
+ # DB_APPEND
+
+ my $lex = new LexFile $Dfile;
+ my @array ;
+ my $value ;
+ ok my $db = tie @array, 'BerkeleyDB::Recno',
+ -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # create a few records
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+
+ my $k = 0 ;
+ ok $db->db_put($k, "fred", DB_APPEND) == 0 ;
+ ok $k == 4 ;
+
+ undef $db ;
+ untie @array ;
+}
+
+{
+ # in-memory Btree with an associated text file
+
+ my $lex = new LexFile $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 ,
+ -ArrayBase => 0,
+ -Property => DB_RENUMBER,
+ -Flags => DB_CREATE ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc\ndef\n\nghi\n" ;
+}
+
+{
+ # in-memory, variable length records, change DB_DELIMETER
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Source => $Dfile2 ,
+ -Property => DB_RENUMBER,
+ -Delim => "-";
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc-def--ghi-";
+}
+
+{
+ # in-memory, fixed length records, default DB_PAD
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Len => 5,
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc def ghi " ;
+}
+
+{
+ # in-memory, fixed length records, change Pad
+
+ my $lex = new LexFile $Dfile, $Dfile2 ;
+ touch $Dfile2 ;
+ my @array ;
+ my $value ;
+ ok tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Len => 5,
+ -Pad => "-",
+ -Source => $Dfile2 ;
+ $array[0] = "abc" ;
+ $array[1] = "def" ;
+ $array[3] = "ghi" ;
+ untie @array ;
+
+ my $x = docat($Dfile2) ;
+ ok $x eq "abc--def-------ghi--" ;
+}
+
+{
+ # 23 Sept 2001 -- push into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok $db = tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Filename => $Dfile ;
+ $FA ? push @array, "first"
+ : $db->push("first") ;
+
+ ok $array[0] eq "first" ;
+ ok $FA ? pop @array : $db->pop() eq "first" ;
+
+ undef $db;
+ untie @array ;
+
+}
+
+{
+ # 23 Sept 2001 -- unshift into an empty array
+ my $lex = new LexFile $Dfile ;
+ my @array ;
+ my $db ;
+ ok $db = tie @array, 'BerkeleyDB::Recno',
+ -ArrayBase => 0,
+ -Flags => DB_CREATE ,
+ -Property => DB_RENUMBER,
+ -Filename => $Dfile ;
+ $FA ? unshift @array, "first"
+ : $db->unshift("first") ;
+
+ ok $array[0] eq "first" ;
+ ok (($FA ? shift @array : $db->shift()) eq "first") ;
+
+ undef $db;
+ untie @array ;
+
+}
+__END__
+
+
+# TODO
+#
+# DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records
diff --git a/lang/perl/BerkeleyDB/t/sequence.t b/lang/perl/BerkeleyDB/t/sequence.t
new file mode 100644
index 00000000..f35f0fdf
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/sequence.t
@@ -0,0 +1,55 @@
+
+use strict ;
+
+use lib 't' ;
+use Test::More;
+use BerkeleyDB;
+use util;
+
+plan(skip_all => "Sequence needs Berkeley DB 4.3.x or better\n" )
+ if $BerkeleyDB::db_version < 4.3;
+
+plan tests => 13;
+
+{
+my $home = "./fred7" ;
+ok my $lexD = new LexDir($home) ;
+my $Dfile = "$home/f" ;
+my $lex = new LexFile $Dfile;
+
+umask(0) ;
+
+my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_MPOOL;
+isa_ok($env, "BerkeleyDB::Env");
+
+my $db = BerkeleyDB::Btree->new(
+ Env => $env,
+ -Filename => $Dfile,
+ -Flags => DB_CREATE
+);
+
+my $seq = $db->db_create_sequence();
+isa_ok($seq, "BerkeleyDB::Sequence");
+
+is int $seq->set_cachesize(42), 0, "set_cachesize";
+
+my $key = "test sequence";
+is int $seq->open($key), DB_NOTFOUND, "opened with no CREATE";
+is int $seq->open($key, DB_CREATE), 0, "opened";
+
+my $gotcs;
+is int $seq->get_cachesize($gotcs), 0;
+is $gotcs, 42;
+
+# First sequence should be 0
+my $val;
+is int $seq->get($val), 0, "get";
+is length($val), 8, "64 bts == 8 bytes";
+
+my $gotkey ='';
+is int $seq->get_key($gotkey), 0, "get_key";
+is $gotkey, $key;
+
+is int $seq->close(), 0, "close";
+}
diff --git a/lang/perl/BerkeleyDB/t/strict.t b/lang/perl/BerkeleyDB/t/strict.t
new file mode 100644
index 00000000..6e13051c
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/strict.t
@@ -0,0 +1,173 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+plan tests => 44;
+
+my $Dfile = "dbhash.tmp";
+my $home = "./fred" ;
+
+umask(0);
+
+{
+ # closing a database & an environment in the correct order.
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env;
+
+ ok $db1->db_close() == 0 ;
+
+ eval { $status = $env->db_appexit() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+
+}
+
+{
+ # closing an environment with an open database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env;
+
+ eval { $env->db_appexit() ; } ;
+ ok $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ;
+ #print "[$@]\n" ;
+
+ undef $db1 ;
+ untie %hash ;
+ undef $env ;
+}
+
+{
+ # closing a transaction & a database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok my $txn = $env->txn_begin() ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok $txn->txn_commit() == 0 ;
+ eval { $status = $db->db_close() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+ eval { $status = $env->db_appexit() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a database with an open transaction
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+
+ ok my $txn = $env->txn_begin() ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ eval { $db->db_close() ; } ;
+ ok $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ;
+ #print "[$@]\n" ;
+ $txn->txn_abort();
+ $db->db_close();
+}
+
+{
+ # closing a cursor & a database
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ ok my $cursor = $db->db_cursor() ;
+ ok $cursor->c_close() == 0 ;
+ eval { $status = $db->db_close() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a database with an open cursor
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+ ok my $cursor = $db->db_cursor() ;
+ eval { $db->db_close() ; } ;
+ ok $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/;
+ #print "[$@]\n" ;
+}
+
+{
+ # closing a transaction & a cursor
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $status ;
+ my $home = 'fred1';
+
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+ ok my $cursor = $db->db_cursor() ;
+ eval { $status = $cursor->c_close() ; } ;
+ ok $status == 0 ;
+ ok $txn->txn_commit() == 0 ;
+ ok $@ eq "" ;
+ eval { $status = $db->db_close() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+ eval { $status = $env->db_appexit() ; } ;
+ ok $status == 0 ;
+ ok $@ eq "" ;
+ #print "[$@]\n" ;
+}
+
diff --git a/lang/perl/BerkeleyDB/t/subdb.t b/lang/perl/BerkeleyDB/t/subdb.t
new file mode 100644
index 00000000..110b4a9a
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/subdb.t
@@ -0,0 +1,210 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use Test::More ;
+use util ;
+
+plan(skip_all => "this needs Berkeley DB 3.x or better\n" )
+ if $BerkeleyDB::db_version < 3;
+
+plan tests => 43;
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $Dfile3 = "dbhash3.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+sub countDatabases
+{
+ my $file = shift ;
+
+ ok my $db = new BerkeleyDB::Unknown -Filename => $file ,
+ -Flags => DB_RDONLY ;
+
+ #my $type = $db->type() ; print "type $type\n" ;
+ ok my $cursor = $db->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $status ;
+ my @dbnames = () ;
+ while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
+ push @dbnames, $k ;
+ }
+
+ ok $status == DB_NOTFOUND;
+
+ return wantarray ? sort @dbnames : scalar @dbnames ;
+
+
+}
+
+# Berkeley DB 3.x specific functionality
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' BerkeleyDB::db_remove -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' BerkeleyDB::db_remove -Bad => 2, -Filename => "fred", -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ ;
+
+ eval ' BerkeleyDB::db_remove -Filename => "a", -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' BerkeleyDB::db_remove -Subname => "a"' ;
+ ok $@ =~ /^Must specify a filename/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' BerkeleyDB::db_remove -Filename => "x", -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+{
+ # subdatabases
+
+ # opening a subdatabse in an exsiting database that doesn't have
+ # subdatabases at all should fail
+
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db, %data) ;
+
+ undef $db ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ;
+ ok ! $db ;
+
+ ok -e $Dfile ;
+ ok ! BerkeleyDB::db_remove(-Filename => $Dfile) ;
+}
+
+{
+ # subdatabases
+
+ # opening a subdatabse in an exsiting database that does have
+ # subdatabases at all, but not this one
+
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db, %data) ;
+
+ undef $db ;
+
+ $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "joe" ;
+
+ ok !$db ;
+
+}
+
+{
+ # subdatabases
+
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db, %data) ;
+ undef $db ;
+
+ is join(",", countDatabases($Dfile)), "fred";
+
+}
+
+{
+ # subdatabases
+
+ # opening a database with multiple subdatabases - handle should be a list
+ # of the subdatabase names
+
+ my $lex = new LexFile $Dfile ;
+
+ ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Subname => "fred" ,
+ -Flags => DB_CREATE ;
+
+ ok my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Subname => "joe" ,
+ -Flags => DB_CREATE ;
+
+ # Add a k/v pair
+ my %data = qw(
+ red sky
+ blue sea
+ black heart
+ yellow belley
+ green grass
+ ) ;
+
+ ok addData($db1, %data) ;
+ ok addData($db2, %data) ;
+
+ undef $db1 ;
+ undef $db2 ;
+
+ is join(",", countDatabases($Dfile)), "fred,joe";
+
+ ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "harry") != 0;
+ ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") == 0 ;
+
+ # should only be one subdatabase
+ is join(",", countDatabases($Dfile)), "joe";
+
+ # can't delete an already deleted subdatabase
+ ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") != 0;
+
+ ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "joe") == 0 ;
+
+ # should only be one subdatabase
+ is countDatabases($Dfile), 0;
+
+ ok -e $Dfile ;
+ ok BerkeleyDB::db_remove(-Filename => $Dfile) == 0 ;
+ ok ! -e $Dfile ;
+ ok BerkeleyDB::db_remove(-Filename => $Dfile) != 0 ;
+}
+
+# db_remove with env
diff --git a/lang/perl/BerkeleyDB/t/txn.t b/lang/perl/BerkeleyDB/t/txn.t
new file mode 100644
index 00000000..51699c5a
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/txn.t
@@ -0,0 +1,316 @@
+#!./perl -w
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+
+use Test::More ;
+
+plan tests => 58;
+
+my $Dfile = "dbhash.tmp";
+
+umask(0);
+
+{
+ # error cases
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE| DB_INIT_MPOOL;
+ eval { $env->txn_begin() ; } ;
+ ok $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
+
+ eval { my $txn_mgr = $env->TxnMgr() ; } ;
+ ok $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
+ undef $env ;
+
+}
+
+{
+ # transaction - abort works
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ my $stat = $env->txn_stat() ;
+ ok $stat->{'st_naborts'} == 1 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - abort works via txnmgr
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn_mgr = $env->TxnMgr() ;
+ ok my $txn = $txn_mgr->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now abort the transaction
+ ok $txn->txn_abort() == 0 ;
+
+ # there shouldn't be any records in the database
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 0 ;
+
+ my $stat = $txn_mgr->txn_stat() ;
+ ok $stat->{'st_naborts'} == 1 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $txn_mgr ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - commit works
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn = $env->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now commit the transaction
+ ok $txn->txn_commit() == 0 ;
+
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+
+ my $stat = $env->txn_stat() ;
+ ok $stat->{'st_naborts'} == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $env ;
+ untie %hash ;
+}
+
+{
+ # transaction - commit works via txnmgr
+
+ my $lex = new LexFile $Dfile ;
+ my %hash ;
+ my $value ;
+
+ my $home = "./fred" ;
+ ok my $lexD = new LexDir($home);
+ ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
+ -Flags => DB_CREATE|DB_INIT_TXN|
+ DB_INIT_MPOOL|DB_INIT_LOCK ;
+ ok my $txn_mgr = $env->TxnMgr() ;
+ ok my $txn = $txn_mgr->txn_begin() ;
+ ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
+ -Flags => DB_CREATE ,
+ -Env => $env,
+ -Txn => $txn ;
+
+ ok $txn->txn_commit() == 0 ;
+ ok $txn = $env->txn_begin() ;
+ $db1->Txn($txn);
+
+ # create some data
+ my %data = (
+ "red" => "boat",
+ "green" => "house",
+ "blue" => "sea",
+ ) ;
+
+ my $ret = 0 ;
+ while (my ($k, $v) = each %data) {
+ $ret += $db1->db_put($k, $v) ;
+ }
+ ok $ret == 0 ;
+
+ # should be able to see all the records
+
+ ok my $cursor = $db1->db_cursor() ;
+ my ($k, $v) = ("", "") ;
+ my $count = 0 ;
+ # sequence forwards
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+ undef $cursor ;
+
+ # now commit the transaction
+ ok $txn->txn_commit() == 0 ;
+
+ $count = 0 ;
+ # sequence forwards
+ ok $cursor = $db1->db_cursor() ;
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
+ ++ $count ;
+ }
+ ok $count == 3 ;
+
+ my $stat = $txn_mgr->txn_stat() ;
+ ok $stat->{'st_naborts'} == 0 ;
+
+ undef $txn ;
+ undef $cursor ;
+ undef $db1 ;
+ undef $txn_mgr ;
+ undef $env ;
+ untie %hash ;
+}
+
diff --git a/lang/perl/BerkeleyDB/t/unknown.t b/lang/perl/BerkeleyDB/t/unknown.t
new file mode 100644
index 00000000..3e31c630
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/unknown.t
@@ -0,0 +1,211 @@
+#!./perl -w
+
+# ID: %I%, %G%
+
+use strict ;
+
+use lib 't' ;
+use BerkeleyDB;
+use util ;
+use Test::More;
+plan tests => 50;
+
+my $Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0) ;
+
+
+# Check for invalid parameters
+{
+ # Check for invalid parameters
+ my $db ;
+ eval ' $db = new BerkeleyDB::Unknown -Stupid => 3 ; ' ;
+ ok $@ =~ /unknown key value\(s\) Stupid/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
+ ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Env => 2 ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+
+ eval ' $db = new BerkeleyDB::Unknown -Txn => "fred" ' ;
+ ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
+
+ my $obj = bless [], "main" ;
+ eval ' $db = new BerkeleyDB::Unknown -Env => $obj ' ;
+ ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
+}
+
+# check the interface to a rubbish database
+{
+ # first an empty file
+ my $lex = new LexFile $Dfile ;
+ ok writeFile($Dfile, "") ;
+
+ ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
+
+ # now a non-database file
+ writeFile($Dfile, "\x2af6") ;
+ ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
+}
+
+# check the interface to a Hash database
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a hash database
+ ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok $db->db_put("some key", "some value") == 0
+ or diag "Cannot db_put: [$!][$BerkeleyDB::Error]\n" ;
+
+ ok $db->db_put("key", "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok $db->type() == DB_HASH ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+
+ my @array ;
+ eval { $db->Tie(\@array)} ;
+ ok $@ =~ /^Tie needs a reference to a hash/ ;
+
+ my %hash ;
+ $db->Tie(\%hash) ;
+ ok $hash{"some key"} eq "some value" ;
+
+}
+
+# check the interface to a Btree database
+
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a hash database
+ ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok $db->db_put("some key", "some value") == 0 ;
+ ok $db->db_put("key", "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ # create a hash database
+ ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok $db->type() == DB_BTREE ;
+ ok $db->db_get("some key", $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_get("key", $value) == 0 ;
+ ok $value eq "value" ;
+
+
+ my @array ;
+ eval { $db->Tie(\@array)} ;
+ ok $@ =~ /^Tie needs a reference to a hash/ ;
+
+ my %hash ;
+ $db->Tie(\%hash) ;
+ ok $hash{"some key"} eq "some value" ;
+
+
+}
+
+# check the interface to a Recno database
+
+if(1)
+{
+ my $lex = new LexFile $Dfile ;
+
+ # create a recno database
+ ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $value ;
+ my $status ;
+ ok $db->db_put(0, "some value") == 0 ;
+ ok $db->db_put(1, "value") == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ # create a hash database
+ ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok $db->type() == DB_RECNO ;
+ ok $db->db_get(0, $value) == 0 ;
+ ok $value eq "some value" ;
+ ok $db->db_get(1, $value) == 0 ;
+ ok $value eq "value" ;
+
+
+ my %hash ;
+ eval { $db->Tie(\%hash)} ;
+ ok $@ =~ /^Tie needs a reference to an array/ ;
+
+ my @array ;
+ $db->Tie(\@array) ;
+ ok $array[1] eq "value" ;
+
+
+}
+
+# check the interface to a Heap database
+
+SKIP:
+{
+ skip "Heap support not available", 9
+ unless BerkeleyDB::has_heap() ;
+
+ my $lex = new LexFile $Dfile ;
+
+ # create a hash database
+ ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
+ -Flags => DB_CREATE ;
+
+ # Add a few k/v pairs
+ my $key1 = "" ;
+ my $key2 ;
+ my $value ;
+ my $status ;
+ ok $db->db_put($key1, "some value", DB_APPEND) == 0 ;
+ ok $db->db_put($key2, "value", DB_APPEND) == 0 ;
+
+ # close the database
+ undef $db ;
+
+ # now open it with Unknown
+ # create a hash database
+ ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
+
+ ok $db->type() == DB_HEAP ;
+ ok $db->db_get($key1, $value) == 0
+ or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
+ ok $value eq "some value" ;
+ ok $db->db_get($key2, $value) == 0 ;
+ ok $value eq "value" ;
+
+
+}
+
+# check i/f to text
diff --git a/lang/perl/BerkeleyDB/t/util.pm b/lang/perl/BerkeleyDB/t/util.pm
new file mode 100644
index 00000000..3a683c07
--- /dev/null
+++ b/lang/perl/BerkeleyDB/t/util.pm
@@ -0,0 +1,354 @@
+package util ;
+
+use strict;
+
+
+package main ;
+
+use strict ;
+use BerkeleyDB ;
+use File::Path qw(rmtree);
+use vars qw(%DB_errors $FA) ;
+
+use vars qw( @StdErrFile );
+
+@StdErrFile = ( -ErrFile => *STDERR, -ErrPrefix => "\n# " ) ;
+
+$| = 1;
+
+%DB_errors = (
+ 'DB_INCOMPLETE' => "DB_INCOMPLETE: Sync was unable to complete",
+ 'DB_KEYEMPTY' => "DB_KEYEMPTY: Non-existent key/data pair",
+ 'DB_KEYEXIST' => "DB_KEYEXIST: Key/data pair already exists",
+ 'DB_LOCK_DEADLOCK' => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
+ 'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
+ 'DB_NOTFOUND' => "DB_NOTFOUND: No matching key/data pair found",
+ 'DB_OLD_VERSION' => "DB_OLDVERSION: Database requires a version upgrade",
+ 'DB_RUNRECOVERY' => "DB_RUNRECOVERY: Fatal error, run database recovery",
+) ;
+
+# full tied array support started in Perl 5.004_57
+# just double check.
+$FA = 0 ;
+{
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+}
+
+{
+ package LexFile ;
+
+ use vars qw( $basename @files ) ;
+ $basename = "db0000" ;
+
+ sub new
+ {
+ my $self = shift ;
+ #my @files = () ;
+ foreach (@_)
+ {
+ $_ = $basename ;
+ 1 while unlink $basename ;
+ push @files, $basename ;
+ ++ $basename ;
+ }
+ bless [ @files ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ chmod 0777, @{ $self } ;
+ for (@$self) { 1 while unlink $_ } ;
+ }
+
+ END
+ {
+ foreach (@files) { unlink $_ }
+ }
+}
+
+
+{
+ package LexDir ;
+
+ use File::Path qw(rmtree);
+
+ use vars qw( $basename %dirs ) ;
+
+ sub new
+ {
+ my $self = shift ;
+ my $dir = shift ;
+
+ rmtree $dir if -e $dir ;
+
+ mkdir $dir, 0777 or return undef ;
+
+ return bless [ $dir ], $self ;
+ }
+
+ sub DESTROY
+ {
+ my $self = shift ;
+ my $dir = $self->[0];
+ #rmtree $dir;
+ $dirs{$dir} ++ ;
+ }
+
+ END
+ {
+ foreach (keys %dirs) {
+ rmtree $_ if -d $_ ;
+ }
+ }
+
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub normalise
+{
+ my $data = shift ;
+ $data =~ s#\r\n#\n#g
+ if $^O eq 'cygwin' ;
+
+ return $data ;
+}
+
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ $result = normalise($result);
+ return $result;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT> || "" ;
+ close(CAT);
+ unlink $file ;
+ $result = normalise($result);
+ return $result;
+}
+
+sub docat_del_sort
+{
+ my $file = shift;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @got = <CAT>;
+ @got = sort @got;
+
+ my $result = join('', @got) || "" ;
+ close(CAT);
+ unlink $file ;
+ $result = normalise($result);
+ return $result;
+}
+
+sub readFile
+{
+ my $file = shift;
+ local $/ = undef;
+ open(RD,$file) || die "Cannot open $file:$!";
+ my $result = <RD>;
+ close(RD);
+ return $result;
+}
+
+sub writeFile
+{
+ my $name = shift ;
+ open(FH, ">$name") or return 0 ;
+ print FH @_ ;
+ close FH ;
+ return 1 ;
+}
+
+sub touch
+{
+ my $file = shift ;
+ open(CAT,">$file") || die "Cannot open $file:$!";
+ close(CAT);
+}
+
+sub joiner
+{
+ my $db = shift ;
+ my $sep = shift ;
+ my ($k, $v) = (0, "") ;
+ my @data = () ;
+
+ my $cursor = $db->db_cursor() or return () ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ push @data, $v ;
+ }
+
+ (scalar(@data), join($sep, @data)) ;
+}
+
+sub joinkeys
+{
+ my $db = shift ;
+ my $sep = shift || " " ;
+ my ($k, $v) = (0, "") ;
+ my @data = () ;
+
+ my $cursor = $db->db_cursor() or return () ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ push @data, $k ;
+ }
+
+ return join($sep, @data) ;
+
+}
+
+sub dumpdb
+{
+ my $db = shift ;
+ my $sep = shift || " " ;
+ my ($k, $v) = (0, "") ;
+ my @data = () ;
+
+ my $cursor = $db->db_cursor() or return () ;
+ for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
+ $status == 0 ;
+ $status = $cursor->c_get($k, $v, DB_NEXT)) {
+ print " [$k][$v]\n" ;
+ }
+
+
+}
+
+sub countRecords
+{
+ my $db = shift ;
+ my ($k, $v) = (0,0) ;
+ my ($count) = 0 ;
+ my ($cursor) = $db->db_cursor() ;
+ #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
+# $status == 0 ;
+# $status = $cursor->c_get($k, $v, DB_NEXT) )
+ while ($cursor->c_get($k, $v, DB_NEXT) == 0)
+ { ++ $count }
+
+ return $count ;
+}
+
+sub addData
+{
+ my $db = shift ;
+ my @data = @_ ;
+ die "addData odd data\n" if @data % 2 != 0 ;
+ my ($k, $v) ;
+ my $ret = 0 ;
+ while (@data) {
+ $k = shift @data ;
+ $v = shift @data ;
+ $ret += $db->db_put($k, $v) ;
+ }
+
+ return ($ret == 0) ;
+}
+
+
+
+# These two subs lifted directly from MLDBM.pm
+#
+sub _compare {
+ use vars qw(%compared);
+ local %compared;
+ return _cmp(@_);
+}
+
+sub _cmp {
+ my($a, $b) = @_;
+
+ # catch circular loops
+ return(1) if $compared{$a.'&*&*&*&*&*'.$b}++;
+# print "$a $b\n";
+# print &Data::Dumper::Dumper($a, $b);
+
+ if(ref($a) and ref($a) eq ref($b)) {
+ if(eval { @$a }) {
+# print "HERE ".@$a." ".@$b."\n";
+ @$a == @$b or return 0;
+# print @$a, ' ', @$b, "\n";
+# print "HERE2\n";
+
+ for(0..@$a-1) {
+ &_cmp($a->[$_], $b->[$_]) or return 0;
+ }
+ } elsif(eval { %$a }) {
+ keys %$a == keys %$b or return 0;
+ for (keys %$a) {
+ &_cmp($a->{$_}, $b->{$_}) or return 0;
+ }
+ } elsif(eval { $$a }) {
+ &_cmp($$a, $$b) or return 0;
+ } else {
+ die("data $a $b not handled");
+ }
+ return 1;
+ } elsif(! ref($a) and ! ref($b)) {
+ return ($a eq $b);
+ } else {
+ return 0;
+ }
+
+}
+
+sub fillout
+{
+ my $var = shift ;
+ my $length = shift ;
+ my $pad = shift || " " ;
+ my $template = $pad x $length ;
+ substr($template, 0, length($var)) = $var ;
+ return $template ;
+}
+
+sub title
+{
+ #diag "" ;
+ ok(1, $_[0]) ;
+ #diag "" ;
+}
+
+
+1;
diff --git a/lang/perl/BerkeleyDB/typemap b/lang/perl/BerkeleyDB/typemap
new file mode 100644
index 00000000..088a25fe
--- /dev/null
+++ b/lang/perl/BerkeleyDB/typemap
@@ -0,0 +1,403 @@
+# typemap for Perl 5 interface to Berkeley DB version 2 & 3
+#
+# SCCS: %I%, %G%
+#
+# written by Paul Marquess <pmqs@cpan.org>
+#
+#################################### DB SECTION
+#
+#
+
+SVnull* T_SV_NULL
+void * T_PV
+db_seq_t T_PV_64
+u_int T_U_INT
+u_int32_t T_U_INT
+int32_t T_U_INT
+db_timeout_t T_U_INT
+const char * T_PV_NULL
+PV_or_NULL T_PV_NULL
+IO_or_NULL T_IO_NULL
+
+AV * T_AV
+
+BerkeleyDB T_PTROBJ
+BerkeleyDB::Common T_PTROBJ_AV
+BerkeleyDB::Hash T_PTROBJ_AV
+BerkeleyDB::Btree T_PTROBJ_AV
+BerkeleyDB::Heap T_PTROBJ_AV
+BerkeleyDB::Recno T_PTROBJ_AV
+BerkeleyDB::Queue T_PTROBJ_AV
+BerkeleyDB::Cursor T_PTROBJ_AV
+BerkeleyDB::TxnMgr T_PTROBJ_AV
+BerkeleyDB::Txn T_PTROBJ_AV
+BerkeleyDB::Log T_PTROBJ_AV
+BerkeleyDB::Lock T_PTROBJ_AV
+BerkeleyDB::Env T_PTROBJ_AV
+BerkeleyDB::Sequence T_PTROBJ_NULL
+
+BerkeleyDB::Raw T_RAW
+BerkeleyDB::Common::Raw T_RAW
+BerkeleyDB::Hash::Raw T_RAW
+BerkeleyDB::Btree::Raw T_RAW
+BerkeleyDB::Heap::Raw T_RAW
+BerkeleyDB::Recno::Raw T_RAW
+BerkeleyDB::Queue::Raw T_RAW
+BerkeleyDB::Cursor::Raw T_RAW
+BerkeleyDB::TxnMgr::Raw T_RAW
+BerkeleyDB::Txn::Raw T_RAW
+BerkeleyDB::Log::Raw T_RAW
+BerkeleyDB::Lock::Raw T_RAW
+BerkeleyDB::Env::Raw T_RAW
+
+BerkeleyDB::Env::Inner T_INNER
+BerkeleyDB::Common::Inner T_INNER
+BerkeleyDB::Txn::Inner T_INNER
+BerkeleyDB::TxnMgr::Inner T_INNER
+# BerkeleyDB__Env T_PTR
+DBT T_dbtdatum
+DBT_OPT T_dbtdatum_opt
+DBT_B T_dbtdatum_btree
+DBTKEY T_dbtkeydatum
+DBTKEY_B T_dbtkeydatum_btree
+DBTKEY_Br T_dbtkeydatum_btree_r
+DBTKEY_Bpr T_dbtkeydatum_btree_pr
+DBTKEY_seq T_dbtkeydatum_seq
+DBTYPE T_U_INT
+DualType T_DUAL
+BerkeleyDB_type * T_IV
+BerkeleyDB_ENV_type * T_IV
+BerkeleyDB_TxnMgr_type * T_IV
+BerkeleyDB_Txn_type * T_IV
+BerkeleyDB__Cursor_type * T_IV
+DB * T_IV
+DB_ENV * T_IV
+
+INPUT
+
+T_AV
+ if (SvROK($arg) && SvTYPE(SvRV($arg)) == SVt_PVAV)
+ /* if (sv_isa($arg, \"${ntype}\")) */
+ $var = (AV*)SvRV($arg);
+ else
+ croak(\"$var is not an array reference\")
+
+T_RAW
+ $var = INT2PTR($type,SvIV($arg)
+
+T_U_INT
+ $var = SvUV($arg)
+
+T_INT
+ $var = SvIV($arg)
+
+T_SV_REF_NULL
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV *)GetInternalObject($arg));
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+T_SV_NULL
+ if ($arg == NULL || $arg == &PL_sv_undef)
+ $var = NULL ;
+ else
+ $var = $arg ;
+
+T_HV_REF_NULL
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else if (sv_derived_from($arg, \"${ntype}\")) {
+ HV * hv = (HV *)GetInternalObject($arg);
+ SV ** svp = hv_fetch(hv, \"db\", 2, FALSE);
+ IV tmp = SvIV(*svp);
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+T_HV_REF
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ HV * hv = (HV *)GetInternalObject($arg);
+ SV ** svp = hv_fetch(hv, \"db\", 2, FALSE);
+ IV tmp = SvIV(*svp);
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+
+T_P_REF
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+
+T_INNER
+ {
+ HV * hv = (HV *)SvRV($arg);
+ SV ** svp = hv_fetch(hv, \"db\", 2, FALSE);
+ IV tmp = SvIV(*svp);
+ $var = INT2PTR($type, tmp);
+ }
+
+T_PV_NULL
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else {
+ STRLEN len;
+ $var = ($type)SvPV($arg,len) ;
+ if (len == 0)
+ $var = NULL ;
+ }
+
+T_PV_64
+ if ($arg == &PL_sv_undef)
+ $var = 0 ;
+ else {
+ STRLEN len;
+ $var = ($type)SvPV($arg,len) ;
+ if (len == 0)
+ $var = NULL ;
+ }
+
+T_IO_NULL
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else
+ $var = IoOFP(sv_2io($arg))
+
+T_PTROBJ_NULL
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+T_PTROBJ_SELF
+ if ($arg == &PL_sv_undef)
+ $var = NULL ;
+ else if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+T_PTROBJ_AV
+ if ($arg == &PL_sv_undef || $arg == NULL)
+ $var = NULL ;
+ else if (sv_derived_from($arg, \"${ntype}\")) {
+ IV tmp = SvIV(getInnerObject($arg)) ;
+ $var = INT2PTR($type, tmp);
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+
+T_dbtkeydatum
+ if (! isHeapDb(db))
+ {
+ SV* my_sv = $arg ;
+ DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+ DBT_clear($var) ;
+ SvGETMAGIC($arg) ;
+ if (db->recno_or_queue) {
+ Value = GetRecnoKey(db, SvIV(my_sv)) ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(db_recno_t);
+ }
+ else {
+ STRLEN len;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+ else
+ {
+ SvGETMAGIC($arg) ;
+ SvUPGRADE($arg, SVt_PV); SvOOK_off($arg); SvPOK_only($arg);
+ /* SvPOK_only($arg); */
+ SvGROW($arg, DB_HEAP_RID_SZ);
+ DBT_clear($var) ;
+ $var.data = SvPVX($arg);
+ $var.size = DB_HEAP_RID_SZ;
+ }
+
+T_dbtkeydatum_seq
+ InputKey_seq($arg, $var)
+
+
+T_dbtkeydatum_btree
+ {
+ SV* my_sv = $arg ;
+ if (! isHeapDb(db))
+ DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+ DBT_clear($var) ;
+ SvGETMAGIC($arg) ;
+ if (db->recno_or_queue ||
+ (db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
+ Value = GetRecnoKey(db, SvIV(my_sv)) ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(db_recno_t);
+ }
+ else {
+ STRLEN len;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+
+T_dbtkeydatum_btree_r
+ {
+ SV* my_sv = $arg ;
+ DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+ DBT_clear($var) ;
+ SvGETMAGIC($arg) ;
+ if (db->recno_or_queue ||
+ (db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
+ Value = GetRecnoKey(db, SvIV(my_sv)) ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(db_recno_t);
+ }
+ else {
+ STRLEN len;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+
+T_dbtkeydatum_btree_pr
+ {
+ if(flagSet(DB_GET_BOTH))
+ {
+ SV* my_sv = $arg ;
+ DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+ DBT_clear($var) ;
+ SvGETMAGIC($arg) ;
+ if (db->recno_or_queue ||
+ (db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
+ Value = GetRecnoKey(db, SvIV(my_sv)) ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(db_recno_t);
+ }
+ else {
+ STRLEN len;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+ else
+ {
+ DBT_clear($var) ;
+ }
+ }
+
+T_dbtdatum
+ {
+ SV* my_sv = $arg ;
+ STRLEN len;
+ DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+ DBT_clear($var) ;
+ SvGETMAGIC($arg) ;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ $var.flags = db->partial ;
+ $var.dlen = db->dlen ;
+ $var.doff = db->doff ;
+ }
+
+T_dbtdatum_opt
+ DBT_clear($var) ;
+ if (flagSetBoth()) {
+ SV* my_sv = $arg ;
+ STRLEN len;
+ DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+ SvGETMAGIC($arg) ;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ $var.flags = db->partial ;
+ $var.dlen = db->dlen ;
+ $var.doff = db->doff ;
+ }
+
+T_dbtdatum_btree
+ DBT_clear($var) ;
+ if (flagSetBoth()) {
+ SV* my_sv = $arg ;
+ STRLEN len;
+ DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+ SvGETMAGIC($arg) ;
+ $var.data = SvPV(my_sv, len);
+ $var.size = (int)len;
+ $var.flags = db->partial ;
+ $var.dlen = db->dlen ;
+ $var.doff = db->doff ;
+ }
+
+
+OUTPUT
+
+T_SV_NULL
+ $arg = $var;
+
+T_RAW
+ sv_setiv($arg, PTR2IV($var));
+
+T_SV_REF_NULL
+ sv_setiv($arg, PTR2IV($var));
+
+T_HV_REF_NULL
+ sv_setiv($arg, PTR2IV($var));
+
+T_HV_REF
+ sv_setiv($arg, PTR2IV($var));
+
+T_P_REF
+ sv_setiv($arg, PTR2IV($var));
+
+T_DUAL
+ setDUALerrno($arg, $var) ;
+
+T_U_INT
+ sv_setuv($arg, (UV)$var);
+
+T_INT
+ sv_setiv($arg, (UV)$var);
+
+T_PV_NULL
+ sv_setpv((SV*)$arg, $var);
+
+T_PV_64
+ sv_setpvn((SV*)$arg, (char*)&$var, sizeof(db_seq_t));
+
+T_dbtkeydatum_btree
+ OutputKey_B($arg, $var)
+T_dbtkeydatum_btree_r
+ OutputKey_Br($arg, $var)
+T_dbtkeydatum_btree_pr
+ OutputKey_Bpr($arg, $var)
+T_dbtkeydatum_seq
+ OutputKey_seq($arg, $var)
+T_dbtkeydatum
+ OutputKey($arg, $var)
+T_dbtdatum
+ OutputValue($arg, $var)
+T_dbtdatum_opt
+ OutputValue($arg, $var)
+T_dbtdatum_btree
+ OutputValue_B($arg, $var)
+
+T_PTROBJ_NULL
+ sv_setref_pv($arg, \"${ntype}\", (void*)$var);
+
+T_PTROBJ_SELF
+ sv_setref_pv($arg, self, (void*)$var);
diff --git a/lang/perl/DB_File/Changes b/lang/perl/DB_File/Changes
new file mode 100644
index 00000000..f527911f
--- /dev/null
+++ b/lang/perl/DB_File/Changes
@@ -0,0 +1,572 @@
+1.824 6 Aug 2011
+
+ * Amendments to tests to work in blead
+ [RT #70108]
+
+1.823 6 Aug 2011
+
+ * croak if attempt to freeze/thaw DB_File object
+ [RT #69985]
+
+1.822 12 March 2011
+
+ * Link rot
+ [rt.cpan.org #69739]
+
+1.822 12 March 2011
+
+ * Keep DB_File's warnings in sync with perl's
+ [rt.cpan.org #66339]
+
+1.821 10 January 2011
+
+ * Fixed typos & spelling errors.
+ [perl #81792]
+
+1.820 28 March 2009
+
+ * remove MAN3PODS from Makefile.PL to match core.
+
+1.819 18 February 2009
+
+ * t/db-recno.t fails if run in a path that contains spaces
+ [rt.cpan.org #43288]
+
+1.818 21 January 2009
+
+ * Updated Makefile.PL for Strawberry Perl.
+ Patch suggested by David Golden.
+
+ * Remove IRIX notes from README. The page referenced doesn't exist
+ anymore.
+
+1.817 27 March 2008
+
+ * Updated dbinfo
+
+ * Applied core patch 32299 - Re-apply change #30562
+
+ * Applied core patch 32208
+
+ * Applied core patch 32884 - use MM->parse_version() in Makefile.PL
+
+ * Applied core patch 32883 - Silence new warning grep in void context warning
+
+ * Applied core patch 32704 to remove use of PL_na in typemap
+
+ * Applied core patch 30562 to fix a build issue on OSF
+
+1.816 28 October 2007
+
+ * Clarified the warning about building with a different version of
+ Berkeley DB that is used at runtime.
+
+ * Also made the boot version check less strict.
+ [rt.cpan.org #30013]
+
+1.815 4 February 2007
+
+ * A few casting cleanups for building with C++ from Steve Peters.
+
+ * Fixed problem with recno which happened if you changed directory after
+ opening the database. Problem reported by Andrew Pam.
+
+
+1.814 11 November 2005
+
+ * Fix from Dominic Dunlop to tidy up an OS-X specific warning in
+ db-btree.t.
+
+ * Silenced a warning about $DB_File::Error only being used once.
+ Issue spotted by Dominic Dunlop.
+
+1.813 31st October 2005
+
+ * Updates for Berkeley DB 4.4
+
+1.812 9th October 2005
+
+ * Added libscan to Makefile.PL
+
+ * Fixed test failing under windows
+
+1.811 12th March 2005
+
+ * Fixed DBM filter bug in seq
+
+1.810 7th August 2004
+
+ * Fixed db-hash.t for Cygwin
+
+ * Added substr tests to db-hast.t
+
+ * Documented AIX build problem in README.
+
+1.809 20th June 2004
+
+ * Merged core patch 22258
+
+ * Merged core patch 22741
+
+ * Fixed core bug 30237.
+ Using substr to pass parameters to the low-level Berkeley DB interface
+ causes problems with Perl 5.8.1 or better.
+ typemap fix supplied by Marcus Holland-Moritz.
+
+1.808 22nd December 2003
+
+ * Added extra DBM Filter tests.
+
+ * Fixed a memory leak in ParseOpenInfo, which whould occur if the
+ opening of the database failed. Leak spotted by Adrian Enache.
+
+1.807 1st November 2003
+
+ * Fixed minor typos on pod documentation - reported by Jeremy Mates &
+ Mark Jason Dominus.
+
+ * dbinfo updated to report when a database is encrypted.
+
+1.806 22nd October 2002
+
+ * Fixed problem when trying to build with a multi-threaded perl.
+
+ * Tidied up the recursion detection code.
+
+ * merged core patch 17844 - missing dTHX declarations.
+
+ * merged core patch 17838
+
+1.805 1st September 2002
+
+ * Added support to allow DB_File to build with Berkeley DB 4.1.X
+
+ * Tightened up the test harness to test that calls to untie don't generate
+ the "untie attempted while %d inner references still exist" warning.
+
+ * added code to guard against calling the callbacks (compare,hash & prefix)
+ recursively.
+
+ * passing undef for the flags and/or mode when opening a database could cause
+ a "Use of uninitialized value in subroutine entry" warning. Now silenced.
+
+ * DBM filter code beefed up to cope with read-only $_.
+
+1.804 2nd June 2002
+
+ * Perl core patch 14939 added a new warning to "splice". This broke the
+ db-recno test harness. Fixed.
+
+ * merged core patches 16502 & 16540.
+
+1.803 1st March 2002
+
+ * Fixed a problem with db-btree.t where it complained about an "our"
+ variable redeclaration.
+
+ * FETCH, STORE & DELETE don't map the flags parameter into the
+ equivalent Berkeley DB function anymore.
+
+1.802 6th January 2002
+
+ * The message about some test failing in db-recno.t had the wrong test
+ numbers. Fixed.
+
+ * merged core patch 13942.
+
+1.801 26th November 2001
+
+ * Fixed typo in Makefile.PL
+
+ * Added "clean" attribute to Makefile.PL
+
+1.800 23rd November 2001
+
+ * use pport.h for perl backward compatibility code.
+
+ * use new ExtUtils::Constant module to generate XS constants.
+
+ * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with
+ "use vars"
+
+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.
+
+ * 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.78 30th July 2001
+
+ * the test in Makefile.PL for AIX used -plthreads. Should have been
+ -lpthreads
+
+ * merged Core patches
+ 10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432
+
+ * added documentation patch regarding duplicate keys from Andrew Johnson
+
+
+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.
+
+ * Minor documentation updates.
+
+ * Merged Core patch 9176
+
+ * Added a patch from Edward Avis that adds support for splice with
+ recno databases.
+
+ * Modified Makefile.PL to only enable the warnings pragma if using perl
+ 5.6.1 or better.
+
+1.76 15th January 2001
+
+ * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work
+ with DB_File on Linux. Thanks to Norbert Bollow for sending details of
+ this approach.
+
+
+1.75 17th December 2000
+
+ * Fixed perl core patch 7703
+
+ * Added support to allow DB_File to be built with Berkeley DB 3.2 --
+ btree_compare, btree_prefix and hash_cb needed to be changed.
+
+ * Updated dbinfo to support Berkeley DB 3.2 file format changes.
+
+
+1.74 10th December 2000
+
+ * A "close" call in DB_File.xs needed parenthesised to stop win32 from
+ thinking it was one of its macros.
+
+ * Updated dbinfo to support Berkeley DB 3.1 file format changes.
+
+ * DB_File.pm & the test hasness now use the warnings pragma (when
+ available).
+
+ * Included Perl core patch 7703 -- size argument for hash_cb is different
+ for Berkeley DB 3.x
+
+ * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C
+ treatment.
+
+ * @a = () produced the warning 'Argument "" isn't numeric in entersub'
+ This has been fixed. Thanks to Edward Avis for spotting this bug.
+
+ * Added note about building under Linux. Included patches.
+
+ * Included Perl core patch 8068 -- fix for bug 20001013.009
+ When run with warnings enabled "$hash{XX} = undef " produced an
+ "Uninitialized value" warning. This has been fixed.
+
+1.73 31st May 2000
+
+ * Added support in version.c for building with threaded Perl.
+
+ * Berkeley DB 3.1 has reenabled support for null keys. The test
+ harness has been updated to reflect this.
+
+1.72 16th January 2000
+
+ * Added hints/sco.pl
+
+ * The module will now use XSLoader when it is available. When it
+ isn't it will use DynaLoader.
+
+ * The locking section in DB_File.pm has been discredited. Many thanks
+ to David Harris for spotting the underlying problem, contributing
+ the updates to the documentation and writing DB_File::Lock (available
+ on CPAN).
+
+1.71 7th September 1999
+
+ * Fixed a bug that prevented 1.70 from compiling under win32
+
+ * Updated to support Berkeley DB 3.x
+
+ * Updated dbinfo for Berkeley DB 3.x file formats.
+
+1.70 4th August 1999
+
+ * Initialise $DB_File::db_ver and $DB_File::db_version with
+ GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
+
+ * Added a BOOT check to test for equivalent versions of db.h &
+ libdb.a/so.
+
+1.69 3rd August 1999
+
+ * fixed a bug in push -- DB_APPEND wasn't working properly.
+
+ * Fixed the R_SETCURSOR bug introduced in 1.68
+
+ * Added a new Perl variable $DB_File::db_ver
+
+1.68 22nd July 1999
+
+ * Merged changes from 5.005_58
+
+ * Fixed a bug in R_IBEFORE & R_IAFTER processing in Berkeley DB
+ 2 databases.
+
+ * Added some of the examples in the POD into the test harness.
+
+1.67 6th June 1999
+
+ * Added DBM Filter documentation to DB_File.pm
+
+ * Fixed DBM Filter code to work with 5.004
+
+ * A few instances of newSVpvn were used in 1.66. This isn't available in
+ Perl 5.004_04 or earlier. Replaced with newSVpv.
+
+1.66 15th March 1999
+
+ * Added DBM Filter code
+
+1.65 6th March 1999
+
+ * Fixed a bug in the recno PUSH logic.
+ * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2
+
+1.64 21st February 1999
+
+ * Tidied the 1.x to 2.x flag mapping code.
+ * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag
+ mapping problem with O_RDONLY on the Hurd
+ * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail.
+
+1.63 19th December 1998
+
+ * Fix to allow DB 2.6.x to build with DB_File
+ * Documentation updated to use push,pop etc in the RECNO example &
+ to include the find_dup & del_dup methods.
+
+1.62 30th November 1998
+
+ Added hints/dynixptx.pl.
+ Fixed typemap -- 1.61 used PL_na instead of na
+
+1.61 19th November 1998
+
+ Added a note to README about how to build Berkeley DB 2.x when
+ using HP-UX.
+ Minor modifications to get the module to build with DB 2.5.x
+ Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis.
+
+1.60
+ Changed the test to check for full tied array support
+
+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.58
+ Tied Array support was enhanced in Perl 5.004_57. DB_File now
+ supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE.
+
+ 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.57
+ If Perl has been compiled with Threads support,the symbol op will be
+ defined. This clashes with a field name in db.h, so it needs to be
+ #undef'ed before db.h is included.
+
+1.56
+ Documented the Solaris 2.5 mutex bug
+
+1.55
+ Merged 1.16 changes.
+
+1.54
+
+ Fixed a small bug in the test harness when run under win32
+ The emulation of fd when useing DB 2.x was busted.
+
+1.53
+
+ Added DB_RENUMBER to flags for recno.
+
+1.52
+
+ Patch from Nick Ing-Simmons now allows DB_File to build on NT.
+ Merged 1.15 patch.
+
+1.51
+
+ Fixed the test harness so that it doesn't expect DB_File to have
+ been installed by the main Perl build.
+
+
+ Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
+
+1.50
+
+ DB_File can now build with either DB 1.x or 2.x, but not both at
+ the same time.
+
+1.16
+
+ A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5
+
+ Small fix for the AIX strict C compiler XLC which doesn't like
+ __attribute__ being defined via proto.h and redefined via db.h. Fix
+ courtesy of Jarkko Hietaniemi.
+
+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.
+
+
+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.13
+
+ Minor changes to DB_FIle.xs and DB_File.pm
+
+1.12
+
+ Documented the incompatibility with version 2 of Berkeley DB.
+
+1.11
+
+ Documented the untie gotcha.
+
+1.10
+
+ Fixed fd method so that it still returns -1 for in-memory files
+ when db 1.86 is used.
+
+1.09
+
+ Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and
+ DB_File::BTREEINFO.
+
+ Changed default mode to 0666.
+
+1.08
+
+ Documented operation of bval.
+
+1.07
+
+ Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+
+1.06
+
+ Minor namespace cleanup: Localized PrintBtree.
+
+1.05
+
+ Made all scripts in the documentation strict and -w clean.
+
+ Added logic to DB_File.xs to allow the module to be built after
+ Perl is installed.
+
+1.04
+
+ Minor documentation changes.
+
+ Fixed a bug in hash_cb. Patches supplied by Dave Hammen,
+ <hammen@gothamcity.jsc.nasa.govt>.
+
+ 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 -w clean.
+
+ Reworked part of the test harness to be more locale friendly.
+
+1.03
+
+ Documentation update.
+
+ DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl
+ automatically.
+
+ The standard hash function exists is now supported.
+
+ Modified the behavior of get_dup. When it returns an associative
+ array, the value is the count of the number of matching BTREE
+ values.
+
+1.02
+
+ Merged OS/2 specific code into DB_File.xs
+
+ Removed some redundant code in DB_File.xs.
+
+ Documentation update.
+
+ Allow negative subscripts with RECNO interface.
+
+ Changed the default flags from O_RDWR to O_CREAT|O_RDWR.
+
+ The example code which showed how to lock a database needed a call
+ to sync added. Without it the resultant database file was empty.
+
+ Added get_dup method.
+
+1.01
+
+ Fixed a core dump problem with SunOS.
+
+ The return value from TIEHASH wasn't set to NULL when dbopen
+ returned an error.
+
+1.0
+
+ DB_File has been in use for over a year. To reflect that, the
+ version number has been incremented to 1.0.
+
+ Added complete support for multiple concurrent callbacks.
+
+ Using the push method on an empty list didn't work properly. This
+ has been fixed.
+
+0.3
+
+ Added prototype support for multiple btree compare callbacks.
+
+0.2
+
+ When DB_File is opening a database file it no longer terminates the
+ process if dbopen returned an error. This allows file protection
+ errors to be caught at run time. Thanks to Judith Grass
+ <grass@cybercash.com> for spotting the bug.
+
+0.1
+
+ First Release.
+
diff --git a/lang/perl/DB_File/DB_File.pm b/lang/perl/DB_File/DB_File.pm
new file mode 100644
index 00000000..d7fba44e
--- /dev/null
+++ b/lang/perl/DB_File/DB_File.pm
@@ -0,0 +1,2316 @@
+# DB_File.pm -- Perl 5 interface to Berkeley DB
+#
+# written by Paul Marquess (pmqs@cpan.org)
+# last modified 28th October 2007
+# version 1.818
+#
+# Copyright (c) 1995-2009 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.
+
+
+package DB_File::HASHINFO ;
+
+require 5.00404;
+
+use warnings;
+use strict;
+use Carp;
+require Tie::Hash;
+@DB_File::HASHINFO::ISA = qw(Tie::Hash);
+
+sub new
+{
+ my $pkg = shift ;
+ my %x ;
+ tie %x, $pkg ;
+ bless \%x, $pkg ;
+}
+
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => {
+ bsize => 1,
+ ffactor => 1,
+ nelem => 1,
+ cachesize => 1,
+ hash => 2,
+ lorder => 1,
+ },
+ GOT => {}
+ }, $pkg ;
+}
+
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ return $self->{GOT}{$key} if exists $self->{VALID}{$key} ;
+
+ my $pkg = ref $self ;
+ croak "${pkg}::FETCH - Unknown element '$key'" ;
+}
+
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ my $type = $self->{VALID}{$key};
+
+ if ( $type )
+ {
+ croak "Key '$key' not associated with a code reference"
+ if $type == 2 && !ref $value && ref $value ne 'CODE';
+ $self->{GOT}{$key} = $value ;
+ return ;
+ }
+
+ my $pkg = ref $self ;
+ croak "${pkg}::STORE - Unknown element '$key'" ;
+}
+
+sub DELETE
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ if ( exists $self->{VALID}{$key} )
+ {
+ delete $self->{GOT}{$key} ;
+ return ;
+ }
+
+ my $pkg = ref $self ;
+ croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
+}
+
+sub EXISTS
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ exists $self->{VALID}{$key} ;
+}
+
+sub NotHere
+{
+ my $self = shift ;
+ my $method = shift ;
+
+ croak ref($self) . " does not define the method ${method}" ;
+}
+
+sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }
+sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") }
+sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") }
+
+package DB_File::RECNOINFO ;
+
+use warnings;
+use strict ;
+
+@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( bval cachesize psize flags lorder reclen bfname )
+ },
+ GOT => {},
+ }, $pkg ;
+}
+
+package DB_File::BTREEINFO ;
+
+use warnings;
+use strict ;
+
+@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => {
+ flags => 1,
+ cachesize => 1,
+ maxkeypage => 1,
+ minkeypage => 1,
+ psize => 1,
+ compare => 2,
+ prefix => 2,
+ lorder => 1,
+ },
+ GOT => {},
+ }, $pkg ;
+}
+
+
+package DB_File ;
+
+use warnings;
+use strict;
+our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
+our ($db_version, $use_XSLoader, $splice_end_array_no_length, $splice_end_array, $Error);
+use Carp;
+
+
+$VERSION = "1.824" ;
+$VERSION = eval $VERSION; # needed for dev releases
+
+{
+ local $SIG{__WARN__} = sub {$splice_end_array_no_length = "@_";};
+ my @a =(1); splice(@a, 3);
+ $splice_end_array_no_length =
+ ($splice_end_array_no_length =~ /^splice\(\) offset past end of array at /);
+}
+{
+ local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
+ my @a =(1); splice(@a, 3, 1);
+ $splice_end_array =
+ ($splice_end_array =~ /^splice\(\) offset past end of array at /);
+}
+
+#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
+$DB_BTREE = new DB_File::BTREEINFO ;
+$DB_HASH = new DB_File::HASHINFO ;
+$DB_RECNO = new DB_File::RECNOINFO ;
+
+require Tie::Hash;
+require Exporter;
+use AutoLoader;
+BEGIN {
+ $use_XSLoader = 1 ;
+ { local $SIG{__DIE__} ; eval { require XSLoader } ; }
+
+ if ($@) {
+ $use_XSLoader = 0 ;
+ require DynaLoader;
+ @ISA = qw(DynaLoader);
+ }
+}
+
+push @ISA, qw(Tie::Hash Exporter);
+@EXPORT = qw(
+ $DB_BTREE $DB_HASH $DB_RECNO
+
+ 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 AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
+
+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);
+};
+
+if ($use_XSLoader)
+ { XSLoader::load("DB_File", $VERSION)}
+else
+ { bootstrap DB_File $VERSION }
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+sub tie_hash_or_array
+{
+ my (@arg) = @_ ;
+ my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;
+
+ use File::Spec;
+ $arg[1] = File::Spec->rel2abs($arg[1])
+ if defined $arg[1] ;
+
+ $arg[4] = tied %{ $arg[4] }
+ if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
+
+ $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];
+ $arg[3] = 0666 if @arg >=4 && ! defined $arg[3];
+
+ # make recno in Berkeley DB version 2 (or better) work like
+ # recno in version 1.
+ if ($db_version >= 4 and ! $tieHASH) {
+ $arg[2] |= O_CREAT();
+ }
+
+ if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and
+ $arg[1] and ! -e $arg[1]) {
+ open(FH, ">$arg[1]") or return undef ;
+ close FH ;
+ chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
+ }
+
+ DoTie_($tieHASH, @arg) ;
+}
+
+sub TIEHASH
+{
+ tie_hash_or_array(@_) ;
+}
+
+sub TIEARRAY
+{
+ tie_hash_or_array(@_) ;
+}
+
+sub CLEAR
+{
+ my $self = shift;
+ my $key = 0 ;
+ my $value = "" ;
+ my $status = $self->seq($key, $value, R_FIRST());
+ my @keys;
+
+ while ($status == 0) {
+ push @keys, $key;
+ $status = $self->seq($key, $value, R_NEXT());
+ }
+ foreach $key (reverse @keys) {
+ my $s = $self->del($key);
+ }
+}
+
+sub EXTEND { }
+
+sub STORESIZE
+{
+ my $self = shift;
+ my $length = shift ;
+ my $current_length = $self->length() ;
+
+ if ($length < $current_length) {
+ my $key ;
+ for ($key = $current_length - 1 ; $key >= $length ; -- $key)
+ { $self->del($key) }
+ }
+ elsif ($length > $current_length) {
+ $self->put($length-1, "") ;
+ }
+}
+
+
+sub SPLICE
+{
+ my $self = shift;
+ my $offset = shift;
+ if (not defined $offset) {
+ warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+ $offset = 0;
+ }
+
+ my $has_length = @_;
+ my $length = @_ ? shift : 0;
+ # Carping about definedness comes _after_ the OFFSET sanity check.
+ # This is so we get the same error messages as Perl's splice().
+ #
+
+ my @list = @_;
+
+ my $size = $self->FETCHSIZE();
+
+ # 'If OFFSET is negative then it start that far from the end of
+ # the array.'
+ #
+ if ($offset < 0) {
+ my $new_offset = $size + $offset;
+ if ($new_offset < 0) {
+ die "Modification of non-creatable array value attempted, "
+ . "subscript $offset";
+ }
+ $offset = $new_offset;
+ }
+
+ if (not defined $length) {
+ warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+ $length = 0;
+ }
+
+ if ($offset > $size) {
+ $offset = $size;
+ warnings::warnif('misc', 'splice() offset past end of array')
+ if $has_length ? $splice_end_array : $splice_end_array_no_length;
+ }
+
+ # 'If LENGTH is omitted, removes everything from OFFSET onward.'
+ if (not defined $length) {
+ $length = $size - $offset;
+ }
+
+ # 'If LENGTH is negative, leave that many elements off the end of
+ # the array.'
+ #
+ if ($length < 0) {
+ $length = $size - $offset + $length;
+
+ if ($length < 0) {
+ # The user must have specified a length bigger than the
+ # length of the array passed in. But perl's splice()
+ # doesn't catch this, it just behaves as for length=0.
+ #
+ $length = 0;
+ }
+ }
+
+ if ($length > $size - $offset) {
+ $length = $size - $offset;
+ }
+
+ # $num_elems holds the current number of elements in the database.
+ my $num_elems = $size;
+
+ # 'Removes the elements designated by OFFSET and LENGTH from an
+ # array,'...
+ #
+ my @removed = ();
+ foreach (0 .. $length - 1) {
+ my $old;
+ my $status = $self->get($offset, $old);
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on get($offset, \$old)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ": error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+ push @removed, $old;
+
+ $status = $self->del($offset);
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on del($offset)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ": error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+
+ -- $num_elems;
+ }
+
+ # ...'and replaces them with the elements of LIST, if any.'
+ my $pos = $offset;
+ while (defined (my $elem = shift @list)) {
+ my $old_pos = $pos;
+ my $status;
+ if ($pos >= $num_elems) {
+ $status = $self->put($pos, $elem);
+ }
+ else {
+ $status = $self->put($pos, $elem, $self->R_IBEFORE);
+ }
+
+ if ($status != 0) {
+ my $msg = "error from Berkeley DB on put($pos, $elem, ...)";
+ if ($status == 1) {
+ $msg .= ' (no such element?)';
+ }
+ else {
+ $msg .= ", error status $status";
+ if (defined $! and $! ne '') {
+ $msg .= ", message $!";
+ }
+ }
+ die $msg;
+ }
+
+ die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"
+ if $old_pos != $pos;
+
+ ++ $pos;
+ ++ $num_elems;
+ }
+
+ if (wantarray) {
+ # 'In list context, returns the elements removed from the
+ # array.'
+ #
+ return @removed;
+ }
+ elsif (defined wantarray and not wantarray) {
+ # 'In scalar context, returns the last element removed, or
+ # undef if no elements are removed.'
+ #
+ if (@removed) {
+ my $last = pop @removed;
+ return "$last";
+ }
+ else {
+ return undef;
+ }
+ }
+ elsif (not defined wantarray) {
+ # Void context
+ }
+ else { die }
+}
+sub ::DB_File::splice { &SPLICE }
+
+sub find_dup
+{
+ croak "Usage: \$db->find_dup(key,value)\n"
+ unless @_ == 3 ;
+
+ my $db = shift ;
+ my ($origkey, $value_wanted) = @_ ;
+ my ($key, $value) = ($origkey, 0);
+ my ($status) = 0 ;
+
+ for ($status = $db->seq($key, $value, R_CURSOR() ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT() ) ) {
+
+ return 0 if $key eq $origkey and $value eq $value_wanted ;
+ }
+
+ return $status ;
+}
+
+sub del_dup
+{
+ croak "Usage: \$db->del_dup(key,value)\n"
+ unless @_ == 3 ;
+
+ my $db = shift ;
+ my ($key, $value) = @_ ;
+ my ($status) = $db->find_dup($key, $value) ;
+ return $status if $status != 0 ;
+
+ $status = $db->del($key, R_CURSOR() ) ;
+ return $status ;
+}
+
+sub get_dup
+{
+ croak "Usage: \$db->get_dup(key [,flag])\n"
+ unless @_ == 2 or @_ == 3 ;
+
+ my $db = shift ;
+ my $key = shift ;
+ my $flag = shift ;
+ my $value = 0 ;
+ my $origkey = $key ;
+ my $wantarray = wantarray ;
+ my %values = () ;
+ my @values = () ;
+ my $counter = 0 ;
+ my $status = 0 ;
+
+ # 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()) ;
+ $status == 0 and $key eq $origkey ;
+ $status = $db->seq($key, $value, R_NEXT()) ) {
+
+ # save the value or count number of matches
+ if ($wantarray) {
+ if ($flag)
+ { ++ $values{$value} }
+ else
+ { push (@values, $value) }
+ }
+ else
+ { ++ $counter }
+
+ }
+
+ return ($wantarray ? ($flag ? %values : @values) : $counter) ;
+}
+
+
+sub STORABLE_freeze
+{
+ my $type = ref shift;
+ croak "Cannot freeze $type object\n";
+}
+
+sub STORABLE_thaw
+{
+ my $type = ref shift;
+ croak "Cannot thaw $type object\n";
+}
+
+
+
+1;
+__END__
+
+=head1 NAME
+
+DB_File - Perl5 access to Berkeley DB version 1.x
+
+=head1 SYNOPSIS
+
+ use DB_File;
+
+ [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ;
+ [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ;
+ [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ;
+
+ $status = $X->del($key [, $flags]) ;
+ $status = $X->put($key, $value [, $flags]) ;
+ $status = $X->get($key, $value [, $flags]) ;
+ $status = $X->seq($key, $value, $flags) ;
+ $status = $X->sync([$flags]) ;
+ $status = $X->fd ;
+
+ # BTREE only
+ $count = $X->get_dup($key) ;
+ @list = $X->get_dup($key) ;
+ %list = $X->get_dup($key, 1) ;
+ $status = $X->find_dup($key, $value) ;
+ $status = $X->del_dup($key, $value) ;
+
+ # RECNO only
+ $a = $X->length;
+ $a = $X->pop ;
+ $X->push(list);
+ $a = $X->shift;
+ $X->unshift(list);
+ @r = $X->splice(offset, length, elements);
+
+ # DBM Filters
+ $old_filter = $db->filter_store_key ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+ untie %hash ;
+ untie @array ;
+
+=head1 DESCRIPTION
+
+B<DB_File> is a module which allows Perl programs to make use of the
+facilities provided by Berkeley DB version 1.x (if you have a newer
+version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>).
+It is assumed that you have a copy of the Berkeley DB manual pages at
+hand when reading this documentation. The interface defined here
+mirrors the Berkeley DB interface closely.
+
+Berkeley DB is a C library which provides a consistent interface to a
+number of database formats. B<DB_File> provides an interface to all
+three of the database types currently supported by Berkeley DB.
+
+The file types are:
+
+=over 5
+
+=item B<DB_HASH>
+
+This database type allows arbitrary key/value pairs to be stored in data
+files. This is equivalent to the functionality provided by other
+hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
+the files created using DB_HASH are not compatible with any of the
+other packages mentioned.
+
+A default hashing algorithm, which will be adequate for most
+applications, is built into Berkeley DB. If you do need to use your own
+hashing algorithm it is possible to write your own in Perl and have
+B<DB_File> use it instead.
+
+=item B<DB_BTREE>
+
+The btree format allows arbitrary key/value pairs to be stored in a
+sorted, balanced binary tree.
+
+As with the DB_HASH format, it is possible to provide a user defined
+Perl routine to perform the comparison of keys. By default, though, the
+keys are stored in lexical order.
+
+=item B<DB_RECNO>
+
+DB_RECNO allows both fixed-length and variable-length flat text files
+to be manipulated using the same key/value pair interface as in DB_HASH
+and DB_BTREE. In this case the key will consist of a record (line)
+number.
+
+=back
+
+=head2 Using DB_File with Berkeley DB version 2 or greater
+
+Although B<DB_File> is intended to be used with Berkeley DB version 1,
+it can also be used with version 2, 3 or 4. In this case the interface is
+limited to the functionality provided by Berkeley DB 1.x. Anywhere the
+version 2 or greater interface differs, B<DB_File> arranges for it to work
+like version 1. This feature allows B<DB_File> scripts that were built
+with version 1 to be migrated to version 2 or greater without any changes.
+
+If you want to make use of the new features available in Berkeley DB
+2.x or greater, use the Perl module B<BerkeleyDB> instead.
+
+B<Note:> The database file format has changed multiple times in Berkeley
+DB version 2, 3 and 4. If you cannot recreate your databases, you
+must dump any existing databases with either the C<db_dump> or the
+C<db_dump185> utility that comes with Berkeley DB.
+Once you have rebuilt DB_File to use Berkeley DB version 2 or greater,
+your databases can be recreated using C<db_load>. Refer to the Berkeley DB
+documentation for further details.
+
+Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley
+DB with DB_File.
+
+=head2 Interface to Berkeley DB
+
+B<DB_File> allows access to Berkeley DB files using the tie() mechanism
+in Perl 5 (for full details, see L<perlfunc/tie()>). This facility
+allows B<DB_File> to access Berkeley DB files using either an
+associative array (for DB_HASH & DB_BTREE file types) or an ordinary
+array (for the DB_RECNO file type).
+
+In addition to the tie() interface, it is also possible to access most
+of the functions provided in the Berkeley DB API directly.
+See L<THE API INTERFACE>.
+
+=head2 Opening a Berkeley DB Database File
+
+Berkeley DB uses the function dbopen() to open or create a database.
+Here is the C prototype for dbopen():
+
+ DB*
+ dbopen (const char * file, int flags, int mode,
+ DBTYPE type, const void * openinfo)
+
+The parameter C<type> is an enumeration which specifies which of the 3
+interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used.
+Depending on which of these is actually chosen, the final parameter,
+I<openinfo> points to a data structure which allows tailoring of the
+specific interface method.
+
+This interface is handled slightly differently in B<DB_File>. Here is
+an equivalent call using B<DB_File>:
+
+ tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ;
+
+The C<filename>, C<flags> and C<mode> parameters are the direct
+equivalent of their dbopen() counterparts. The final parameter $DB_HASH
+performs the function of both the C<type> and C<openinfo> parameters in
+dbopen().
+
+In the example above $DB_HASH is actually a pre-defined reference to a
+hash object. B<DB_File> has three of these pre-defined references.
+Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.
+
+The keys allowed in each of these pre-defined references is limited to
+the names used in the equivalent C structure. So, for example, the
+$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,
+C<ffactor>, C<hash>, C<lorder> and C<nelem>.
+
+To change one of these elements, just assign to it like this:
+
+ $DB_HASH->{'cachesize'} = 10000 ;
+
+The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are
+usually adequate for most applications. If you do need to create extra
+instances of these objects, constructors are available for each file
+type.
+
+Here are examples of the constructors and the valid options available
+for DB_HASH, DB_BTREE and DB_RECNO respectively.
+
+ $a = new DB_File::HASHINFO ;
+ $a->{'bsize'} ;
+ $a->{'cachesize'} ;
+ $a->{'ffactor'};
+ $a->{'hash'} ;
+ $a->{'lorder'} ;
+ $a->{'nelem'} ;
+
+ $b = new DB_File::BTREEINFO ;
+ $b->{'flags'} ;
+ $b->{'cachesize'} ;
+ $b->{'maxkeypage'} ;
+ $b->{'minkeypage'} ;
+ $b->{'psize'} ;
+ $b->{'compare'} ;
+ $b->{'prefix'} ;
+ $b->{'lorder'} ;
+
+ $c = new DB_File::RECNOINFO ;
+ $c->{'bval'} ;
+ $c->{'cachesize'} ;
+ $c->{'psize'} ;
+ $c->{'flags'} ;
+ $c->{'lorder'} ;
+ $c->{'reclen'} ;
+ $c->{'bfname'} ;
+
+The values stored in the hashes above are mostly the direct equivalent
+of their C counterpart. Like their C counterparts, all are set to a
+default values - that means you don't have to set I<all> of the
+values when you only want to change one. Here is an example:
+
+ $a = new DB_File::HASHINFO ;
+ $a->{'cachesize'} = 12345 ;
+ tie %y, 'DB_File', "filename", $flags, 0777, $a ;
+
+A few of the options need extra discussion here. When used, the C
+equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers
+to C functions. In B<DB_File> these keys are used to store references
+to Perl subs. Below are templates for each of the subs:
+
+ sub hash
+ {
+ my ($data) = @_ ;
+ ...
+ # return the hash value for $data
+ return $hash ;
+ }
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ sub prefix
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return number of bytes of $key2 which are
+ # necessary to determine that it is greater than $key1
+ return $bytes ;
+ }
+
+See L<Changing the BTREE sort order> for an example of using the
+C<compare> template.
+
+If you are using the DB_RECNO interface and you intend making use of
+C<bval>, you should check out L<The 'bval' Option>.
+
+=head2 Default Parameters
+
+It is possible to omit some or all of the final 4 parameters in the
+call to C<tie> and let them take default values. As DB_HASH is the most
+common file format used, the call:
+
+ tie %A, "DB_File", "filename" ;
+
+is equivalent to:
+
+ tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ;
+
+It is also possible to omit the filename parameter as well, so the
+call:
+
+ tie %A, "DB_File" ;
+
+is equivalent to:
+
+ tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ;
+
+See L<In Memory Databases> for a discussion on the use of C<undef>
+in place of a filename.
+
+=head2 In Memory Databases
+
+Berkeley DB allows the creation of in-memory databases by using NULL
+(that is, a C<(char *)0> in C) in place of the filename. B<DB_File>
+uses C<undef> instead of NULL to provide this functionality.
+
+=head1 DB_HASH
+
+The DB_HASH file format is probably the most commonly used of the three
+file formats that B<DB_File> supports. It is also very straightforward
+to use.
+
+=head2 A Simple Example
+
+This example shows how to create a database, add key/value pairs to the
+database, delete keys/value pairs and finally how to enumerate the
+contents of the database.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ our (%h, $k, $v) ;
+
+ unlink "fruit" ;
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH
+ or die "Cannot open file 'fruit': $!\n";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved is in an apparently random order.
+
+=head1 DB_BTREE
+
+The DB_BTREE format is useful when you want to store data in a given
+order. By default the keys will be stored in lexical order, but as you
+will see from the example shown in the next section, it is very easy to
+define your own sorting function.
+
+=head2 Changing the BTREE sort order
+
+This script shows how to override the default sorting algorithm that
+BTREE uses. Instead of using the normal lexical ordering, a case
+insensitive compare function will be used.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # specify the Perl sub that will do the comparison
+ $DB_BTREE->{'compare'} = \&Compare ;
+
+ unlink "tree" ;
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open file 'tree': $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
+
+You cannot change the ordering once the database has been created. Thus
+you must use the same compare function every time you access the
+database.
+
+=item 3
+
+Duplicate keys are entirely defined by the comparison function.
+In the case-insensitive example above, the keys: 'KEY' and 'key'
+would be considered duplicates, and assigning to the second one
+would overwrite the first. If duplicates are allowed for (with the
+R_DUP flag discussed below), only a single copy of duplicate keys
+is stored in the database --- so (again with example above) assigning
+three values to the keys: 'KEY', 'Key', and 'key' would leave just
+the first key: 'KEY' in the database with three values. For some
+situations this results in information loss, so care should be taken
+to provide fully qualified comparison functions when necessary.
+For example, the above comparison routine could be modified to
+additionally compare case-sensitively if two keys are equal in the
+case insensitive comparison:
+
+ sub compare {
+ my($key1, $key2) = @_;
+ lc $key1 cmp lc $key2 ||
+ $key1 cmp $key2;
+ }
+
+And now you will only have duplicates when the keys themselves
+are truly the same. (note: in versions of the db library prior to
+about November 1996, such duplicate keys were retained so it was
+possible to recover the original keys in sets of keys that
+compared as equal).
+
+
+=back
+
+=head2 Handling Duplicate Keys
+
+The BTREE file type optionally allows a single key to be associated
+with an arbitrary number of values. This option is enabled by setting
+the flags element of C<$DB_BTREE> to R_DUP when creating the database.
+
+There are some difficulties in using the tied hash interface if you
+want to manipulate a BTREE database with duplicate keys. Consider this
+code:
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, %h) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the associative array
+ # and print each key/value pair.
+ foreach (sort keys %h)
+ { print "$_ -> $h{$_}\n" }
+
+ untie %h ;
+
+Here is the output:
+
+ Smith -> John
+ Wall -> Larry
+ Wall -> Larry
+ Wall -> Larry
+ mouse -> mickey
+
+As you can see 3 records have been successfully created with key C<Wall>
+- the only thing is, when they are retrieved from the database they
+I<seem> to have the same value, namely C<Larry>. The problem is caused
+by the way that the associative array interface works. Basically, when
+the associative array interface is used to fetch the value associated
+with a given key, it will only ever retrieve the first value.
+
+Although it may not be immediately obvious from the code above, the
+associative array interface can be used to write values with duplicate
+keys, but it cannot be used to read them back from the database.
+
+The way to get around this problem is to use the Berkeley DB API method
+called C<seq>. This method allows sequential access to key/value
+pairs. See L<THE API INTERFACE> for details of both the C<seq> method
+and the API in general.
+
+Here is the script above rewritten using the C<seq> API method.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $status, $key, $value) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # 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) )
+ { print "$key -> $value\n" }
+
+ undef $x ;
+ untie %h ;
+
+that prints:
+
+ Smith -> John
+ Wall -> Brick
+ Wall -> Brick
+ Wall -> Larry
+ mouse -> mickey
+
+This time we have got all the key/value pairs, including the multiple
+values associated with the key C<Wall>.
+
+To make life easier when dealing with duplicate keys, B<DB_File> comes with
+a few utility methods.
+
+=head2 The get_dup() Method
+
+The C<get_dup> method assists in
+reading duplicate values from BTREE databases. The method can take the
+following forms:
+
+ $count = $x->get_dup($key) ;
+ @list = $x->get_dup($key) ;
+ %list = $x->get_dup($key, 1) ;
+
+In a scalar context the method returns the number of values associated
+with the key, C<$key>.
+
+In list context, it returns all the values which match C<$key>. Note
+that the values will be returned in an apparently random order.
+
+In list context, if the second parameter is present and evaluates
+TRUE, the method returns an associative array. The keys of the
+associative array correspond to the values that matched in the BTREE
+and the values of the array are a count of the number of times that
+particular value occurred in the BTREE.
+
+So assuming the database created above, we can use C<get_dup> like
+this:
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h) ;
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ my $cnt = $x->get_dup("Wall") ;
+ print "Wall occurred $cnt times\n" ;
+
+ my %hash = $x->get_dup("Wall", 1) ;
+ print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
+
+ my @list = sort $x->get_dup("Wall") ;
+ print "Wall => [@list]\n" ;
+
+ @list = $x->get_dup("Smith") ;
+ print "Smith => [@list]\n" ;
+
+ @list = $x->get_dup("Dog") ;
+ print "Dog => [@list]\n" ;
+
+
+and it will print:
+
+ Wall occurred 3 times
+ Larry is there
+ There are 2 Brick Walls
+ Wall => [Brick Brick Larry]
+ Smith => [John]
+ Dog => []
+
+=head2 The find_dup() Method
+
+ $status = $X->find_dup($key, $value) ;
+
+This method checks for the existence of a specific key/value pair. If the
+pair exists, the cursor is left pointing to the pair and the method
+returns 0. Otherwise the method returns a non-zero value.
+
+Assuming the database from the previous example:
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $found) ;
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ print "Harry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+prints this
+
+ Larry Wall is there
+ Harry Wall is not there
+
+
+=head2 The del_dup() Method
+
+ $status = $X->del_dup($key, $value) ;
+
+This method deletes a specific key/value pair. It returns
+0 if they exist and have been deleted successfully.
+Otherwise the method returns a non-zero value.
+
+Again assuming the existence of the C<tree> database
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $found) ;
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $x->del_dup("Wall", "Larry") ;
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+prints this
+
+ Larry Wall is not there
+
+=head2 Matching Partial Keys
+
+The BTREE interface has a feature which allows partial keys to be
+matched. This functionality is I<only> available when the C<seq> method
+is used along with the R_CURSOR flag.
+
+ $x->seq($key, $value, R_CURSOR) ;
+
+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 warnings ;
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ my ($filename, $x, %h, $st, $key, $value) ;
+
+ sub match
+ {
+ my $key = shift ;
+ my $value = 0;
+ my $orig_key = $key ;
+ $x->seq($key, $value, R_CURSOR) ;
+ print "$orig_key\t-> $key\t-> $value\n" ;
+ }
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'mouse'} = 'mickey' ;
+ $h{'Wall'} = 'Larry' ;
+ $h{'Walls'} = 'Brick' ;
+ $h{'Smith'} = 'John' ;
+
+
+ $key = $value = 0 ;
+ print "IN ORDER\n" ;
+ for ($st = $x->seq($key, $value, R_FIRST) ;
+ $st == 0 ;
+ $st = $x->seq($key, $value, R_NEXT) )
+
+ { print "$key -> $value\n" }
+
+ print "\nPARTIAL MATCH\n" ;
+
+ match "Wa" ;
+ match "A" ;
+ match "a" ;
+
+ undef $x ;
+ untie %h ;
+
+Here is the output:
+
+ IN ORDER
+ Smith -> John
+ Wall -> Larry
+ Walls -> Brick
+ mouse -> mickey
+
+ PARTIAL MATCH
+ Wa -> Wall -> Larry
+ A -> Smith -> John
+ a -> mouse -> mickey
+
+=head1 DB_RECNO
+
+DB_RECNO provides an interface to flat text files. Both variable and
+fixed length records are supported.
+
+In order to make RECNO more compatible with Perl, the array offset for
+all RECNO arrays begins at 0 rather than 1 as in Berkeley DB.
+
+As with normal Perl arrays, a RECNO array can be accessed using
+negative indexes. The index -1 refers to the last element of the array,
+-2 the second last, and so on. Attempting to access an element before
+the start of the array will raise a fatal run-time error.
+
+=head2 The 'bval' Option
+
+The operation of the bval option warrants some discussion. Here is the
+definition of bval from the Berkeley DB 1.85 recno manual page:
+
+ The delimiting byte to be used to mark the end of a
+ record for variable-length records, and the pad charac-
+ ter for fixed-length records. If no value is speci-
+ fied, newlines (``\n'') are used to mark the end of
+ variable-length records and fixed-length records are
+ padded with spaces.
+
+The second sentence is wrong. In actual fact bval will only default to
+C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL
+openinfo parameter is used at all, the value that happens to be in bval
+will be used. That means you always have to specify bval when making
+use of any of the options in the openinfo parameter. This documentation
+error will be fixed in the next release of Berkeley DB.
+
+That clarifies the situation with regards Berkeley DB itself. What
+about B<DB_File>? Well, the behavior defined in the quote above is
+quite useful, so B<DB_File> conforms to it.
+
+That means that you can specify other options (e.g. cachesize) and
+still have bval default to C<"\n"> for variable length records, and
+space for fixed length records.
+
+Also note that the bval option only allows you to specify a single byte
+as a delimiter.
+
+=head2 A Simple Example
+
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
+L<Extra RECNO Methods> for a workaround).
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO
+ or die "Cannot open file 'text': $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ # use a negative index
+ print "The last element is $h[-1]\n" ;
+ print "The 2nd last element is $h[-2]\n" ;
+
+ untie @h ;
+
+Here is the output from the script:
+
+ The array contains 5 entries
+ popped black
+ shifted white
+ Element 1 Exists with value blue
+ The last element is green
+ The 2nd last element is yellow
+
+=head2 Extra RECNO Methods
+
+If you are using a version of Perl earlier than 5.004_57, the tied
+array interface is quite limited. In the example script above
+C<push>, C<pop>, C<shift>, C<unshift>
+or determining the array length will not work with a tied array.
+
+To make the interface more useful for older versions of Perl, a number
+of methods are supplied with B<DB_File> to simulate the missing array
+operations. All these methods are accessed via the object returned from
+the tie call.
+
+Here are the methods:
+
+=over 5
+
+=item B<$X-E<gt>push(list) ;>
+
+Pushes the elements of C<list> to the end of the array.
+
+=item B<$value = $X-E<gt>pop ;>
+
+Removes and returns the last element of the array.
+
+=item B<$X-E<gt>shift>
+
+Removes and returns the first element of the array.
+
+=item B<$X-E<gt>unshift(list) ;>
+
+Pushes the elements of C<list> to the start of the array.
+
+=item B<$X-E<gt>length>
+
+Returns the number of elements in the array.
+
+=item B<$X-E<gt>splice(offset, length, elements);>
+
+Returns a splice of the array.
+
+=back
+
+=head2 Another Example
+
+Here is a more complete example that makes use of some of the methods
+described above. It also makes use of the API interface directly (see
+L<THE API INTERFACE>).
+
+ use warnings ;
+ use strict ;
+ my (@h, $H, $file, $i) ;
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+and this is what it outputs:
+
+ ORIGINAL
+ 0: zero
+ 1: one
+ 2: two
+ 3: three
+ 4: four
+
+ The last record was [four]
+ The first record was [zero]
+
+ REVERSE
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+ REVERSE again
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+Notes:
+
+=over 5
+
+=item 1.
+
+Rather than iterating through the array, C<@h> like this:
+
+ foreach $i (@h)
+
+it is necessary to use either this:
+
+ foreach $i (0 .. $H->length - 1)
+
+or this:
+
+ for ($a = $H->get($k, $v, R_FIRST) ;
+ $a == 0 ;
+ $a = $H->get($k, $v, R_NEXT) )
+
+=item 2.
+
+Notice that both times the C<put> method was used the record index was
+specified using a variable, C<$i>, rather than the literal value
+itself. This is because C<put> will return the record number of the
+inserted line via that parameter.
+
+=back
+
+=head1 THE API INTERFACE
+
+As well as accessing Berkeley DB using a tied hash or array, it is also
+possible to make direct use of most of the API functions defined in the
+Berkeley DB documentation.
+
+To do this you need to store a copy of the object returned from the tie.
+
+ $db = tie %hash, "DB_File", "filename" ;
+
+Once you have done that, you can access the Berkeley DB API functions
+as B<DB_File> methods directly like this:
+
+ $db->put($key, $value, R_NOOVERWRITE) ;
+
+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.
+
+ use DB_File ;
+ $db = tie %hash, "DB_File", "filename"
+ or die "Cannot tie filename: $!" ;
+ ...
+ undef $db ;
+ untie %hash ;
+
+See L<The untie() Gotcha> for more details.
+
+All the functions defined in L<dbopen> are available except for
+close() and dbopen() itself. The B<DB_File> method interface to the
+supported functions have been implemented to mirror the way Berkeley DB
+works whenever possible. In particular note that:
+
+=over 5
+
+=item *
+
+The methods return a status value. All return 0 on success.
+All return -1 to signify an error and set C<$!> to the exact
+error code. The return code 1 generally (but not always) means that the
+key specified did not exist in the database.
+
+Other return codes are defined. See below and in the Berkeley DB
+documentation for details. The Berkeley DB documentation should be used
+as the definitive source.
+
+=item *
+
+Whenever a Berkeley DB function returns data via one of its parameters,
+the equivalent B<DB_File> method does exactly the same.
+
+=item *
+
+If you are careful, it is possible to mix API calls with the tied
+hash/array interface in the same piece of code. Although only a few of
+the methods used to implement the tied interface currently make use of
+the cursor, you should always assume that the cursor has been changed
+any time the tied hash/array interface is used. As an example, this
+code will probably not do what you expect:
+
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
+
+ # Get the first key/value pair and set the cursor
+ $X->seq($key, $value, R_FIRST) ;
+
+ # this line will modify the cursor
+ $count = scalar keys %x ;
+
+ # Get the second key/value pair.
+ # oops, it didn't, it got the last key/value pair!
+ $X->seq($key, $value, R_NEXT) ;
+
+The code above can be rearranged to get around the problem, like this:
+
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
+
+ # this line will modify the cursor
+ $count = scalar keys %x ;
+
+ # Get the first key/value pair and set the cursor
+ $X->seq($key, $value, R_FIRST) ;
+
+ # Get the second key/value pair.
+ # worked this time.
+ $X->seq($key, $value, R_NEXT) ;
+
+=back
+
+All the constants defined in L<dbopen> for use in the flags parameters
+in the methods defined below are also available. Refer to the Berkeley
+DB documentation for the precise meaning of the flags values.
+
+Below is a list of the methods available.
+
+=over 5
+
+=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;>
+
+Given a key (C<$key>) this method reads the value associated with it
+from the database. The value read from the database is returned in the
+C<$value> parameter.
+
+If the key does not exist the method returns 1.
+
+No flags are currently defined for this method.
+
+=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;>
+
+Stores the key/value pair in the database.
+
+If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter
+will have the record number of the inserted key/value pair set.
+
+Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
+R_SETCURSOR.
+
+=item B<$status = $X-E<gt>del($key [, $flags]) ;>
+
+Removes all key/value pairs with key C<$key> from the database.
+
+A return code of 1 means that the requested key was not in the
+database.
+
+R_CURSOR is the only valid flag at present.
+
+=item B<$status = $X-E<gt>fd ;>
+
+Returns the file descriptor for the underlying database.
+
+See L<Locking: The Trouble with fd> for an explanation for why you should
+not use C<fd> to lock your database.
+
+=item B<$status = $X-E<gt>seq($key, $value, $flags) ;>
+
+This interface allows sequential retrieval from the database. See
+L<dbopen> for full details.
+
+Both the C<$key> and C<$value> parameters will be set to the key/value
+pair read from the database.
+
+The flags parameter is mandatory. The valid flag values are R_CURSOR,
+R_FIRST, R_LAST, R_NEXT and R_PREV.
+
+=item B<$status = $X-E<gt>sync([$flags]) ;>
+
+Flushes any cached buffers to disk.
+
+R_RECNOSYNC is the only valid flag at present.
+
+=back
+
+=head1 DBM FILTERS
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a
+DBM database.
+
+There are four methods associated with DBM Filters. All work identically,
+and each is used to install (or uninstall) a single DBM Filter. Each
+expects a single parameter, namely a reference to a sub. The only
+difference between them is the place that the filter is installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database
+that you need to share with a third-party C application. The C application
+assumes that I<all> keys and values are NULL terminated. Unfortunately
+when Perl writes to DBM databases it doesn't use NULL termination, so
+your Perl application will have to manage NULL termination itself. When
+you write to the database you will have to use something like this:
+
+ $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ my %hash ;
+ my $filename = "filt" ;
+ unlink $filename ;
+
+ my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
+ or die "Cannot open $filename: $!\n" ;
+
+ # Install DBM Filters
+ $db->filter_fetch_key ( sub { s/\0$// } ) ;
+ $db->filter_store_key ( sub { $_ .= "\0" } ) ;
+ $db->filter_fetch_value( sub { s/\0$// } ) ;
+ $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+ $hash{"abc"} = "def" ;
+ my $a = $hash{"ABC"} ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+ $hash{12345} = "something" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ my %hash ;
+ my $filename = "filt" ;
+ unlink $filename ;
+
+
+ my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH
+ or die "Cannot open $filename: $!\n" ;
+
+ $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ;
+ $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ;
+ $hash{123} = "def" ;
+ # ...
+ undef $db ;
+ untie %hash ;
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 HINTS AND TIPS
+
+
+=head2 Locking: The Trouble with fd
+
+Until version 1.72 of this module, the recommended technique for locking
+B<DB_File> databases was to flock the filehandle returned from the "fd"
+function. Unfortunately this technique has been shown to be fundamentally
+flawed (Kudos to David Harris for tracking this down). Use it at your own
+peril!
+
+The locking technique went like this.
+
+ $db = tie(%db, 'DB_File', 'foo.db', O_CREAT|O_RDWR, 0644)
+ || die "dbcreat foo.db $!";
+ $fd = $db->fd;
+ open(DB_FH, "+<&=$fd") || die "dup $!";
+ flock (DB_FH, LOCK_EX) || die "flock: $!";
+ ...
+ $db{"Tom"} = "Jerry" ;
+ ...
+ flock(DB_FH, LOCK_UN);
+ undef $db;
+ untie %db;
+ close(DB_FH);
+
+In simple terms, this is what happens:
+
+=over 5
+
+=item 1.
+
+Use "tie" to open the database.
+
+=item 2.
+
+Lock the database with fd & flock.
+
+=item 3.
+
+Read & Write to the database.
+
+=item 4.
+
+Unlock and close the database.
+
+=back
+
+Here is the crux of the problem. A side-effect of opening the B<DB_File>
+database in step 2 is that an initial block from the database will get
+read from disk and cached in memory.
+
+To see why this is a problem, consider what can happen when two processes,
+say "A" and "B", both want to update the same B<DB_File> database
+using the locking steps outlined above. Assume process "A" has already
+opened the database and has a write lock, but it hasn't actually updated
+the database yet (it has finished step 2, but not started step 3 yet). Now
+process "B" tries to open the same database - step 1 will succeed,
+but it will block on step 2 until process "A" releases the lock. The
+important thing to notice here is that at this point in time both
+processes will have cached identical initial blocks from the database.
+
+Now process "A" updates the database and happens to change some of the
+data held in the initial buffer. Process "A" terminates, flushing
+all cached data to disk and releasing the database lock. At this point
+the database on disk will correctly reflect the changes made by process
+"A".
+
+With the lock released, process "B" can now continue. It also updates the
+database and unfortunately it too modifies the data that was in its
+initial buffer. Once that data gets flushed to disk it will overwrite
+some/all of the changes process "A" made to the database.
+
+The result of this scenario is at best a database that doesn't contain
+what you expect. At worst the database will corrupt.
+
+The above won't happen every time competing process update the same
+B<DB_File> database, but it does illustrate why the technique should
+not be used.
+
+=head2 Safe ways to lock a database
+
+Starting with version 2.x, Berkeley DB has internal support for locking.
+The companion module to this one, B<BerkeleyDB>, provides an interface
+to this locking functionality. If you are serious about locking
+Berkeley DB databases, I strongly recommend using B<BerkeleyDB>.
+
+If using B<BerkeleyDB> isn't an option, there are a number of modules
+available on CPAN that can be used to implement locking. Each one
+implements locking differently and has different goals in mind. It is
+therefore worth knowing the difference, so that you can pick the right
+one for your application. Here are the three locking wrappers:
+
+=over 5
+
+=item B<Tie::DB_Lock>
+
+A B<DB_File> wrapper which creates copies of the database file for
+read access, so that you have a kind of a multiversioning concurrent read
+system. However, updates are still serial. Use for databases where reads
+may be lengthy and consistency problems may occur.
+
+=item B<Tie::DB_LockFile>
+
+A B<DB_File> wrapper that has the ability to lock and unlock the database
+while it is being used. Avoids the tie-before-flock problem by simply
+re-tie-ing the database when you get or drop a lock. Because of the
+flexibility in dropping and re-acquiring the lock in the middle of a
+session, this can be massaged into a system that will work with long
+updates and/or reads if the application follows the hints in the POD
+documentation.
+
+=item B<DB_File::Lock>
+
+An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile
+before tie-ing the database and drops the lock after the untie. Allows
+one to use the same lockfile for multiple databases to avoid deadlock
+problems, if desired. Use for databases where updates are reads are
+quick and simple flock locking semantics are enough.
+
+=back
+
+=head2 Sharing Databases With C Applications
+
+There is no technical reason why a Berkeley DB database cannot be
+shared by both a Perl and a C application.
+
+The vast majority of problems that are reported in this area boil down
+to the fact that C strings are NULL terminated, whilst Perl strings are
+not. See L<DBM FILTERS> for a generic way to work around this problem.
+
+Here is a real example. Netscape 2.0 keeps a record of the locations you
+visit along with the time you last visited them in a DB_HASH database.
+This is usually stored in the file F<~/.netscape/history.db>. The key
+field in the database is the location string and the value field is the
+time the location was last visited stored as a 4 byte binary value.
+
+If you haven't already guessed, the location string is stored with a
+terminating NULL. This means you need to be careful when accessing the
+database.
+
+Here is a snippet of code that is loosely based on Tom Christiansen's
+I<ggh> script (available from your nearest CPAN archive in
+F<authors/id/TOMC/scripts/nshist.gz>).
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ my ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ;
+ $dotdir = $ENV{HOME} || $ENV{LOGNAME};
+
+ $HISTORY = "$dotdir/.netscape/history.db";
+
+ tie %hist_db, 'DB_File', $HISTORY
+ or die "Cannot open $HISTORY: $!\n" ;;
+
+ # Dump the complete database
+ while ( ($href, $binary_time) = each %hist_db ) {
+
+ # remove the terminating NULL
+ $href =~ s/\x00$// ;
+
+ # convert the binary time into a user friendly string
+ $date = localtime unpack("V", $binary_time);
+ print "$date $href\n" ;
+ }
+
+ # check for the existence of a specific key
+ # remember to add the NULL
+ if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) {
+ $date = localtime unpack("V", $binary_time) ;
+ print "Last visited mox.perl.com on $date\n" ;
+ }
+ else {
+ print "Never visited mox.perl.com\n"
+ }
+
+ untie %hist_db ;
+
+=head2 The untie() Gotcha
+
+If you make use of the Berkeley DB API, it is I<very> strongly
+recommended that you read L<perltie/The untie Gotcha>.
+
+Even if you don't currently make use of the API interface, it is still
+worth reading it.
+
+Here is an example which illustrates the problem from a B<DB_File>
+perspective:
+
+ use DB_File ;
+ use Fcntl ;
+
+ my %x ;
+ my $X ;
+
+ $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC
+ or die "Cannot tie first time: $!" ;
+
+ $x{123} = 456 ;
+
+ untie %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 14.
+
+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.
+
+Having read L<perltie> you will probably have already guessed that the
+error is caused by the extra copy of the tied object stored in C<$X>.
+If you haven't, then the problem boils down to the fact that the
+B<DB_File> destructor, DESTROY, will not be called until I<all>
+references to the tied object are destroyed. Both the tied variable,
+C<%x>, and C<$X> above hold a reference to the object. The call to
+untie() will destroy the first, but C<$X> still holds a valid
+reference, so the destructor will not get called and the database file
+F<tst.fil> will remain open. The fact that Berkeley DB then reports the
+attempt to open a database that is already open via the catch-all
+"Invalid argument" doesn't help.
+
+If you run the script with the C<-w> flag the error message becomes:
+
+ untie attempted while 1 inner references still exist at bad.file line 12.
+ Cannot tie second time: Invalid argument at bad.file line 14.
+
+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
+ ...
+
+
+=head1 COMMON QUESTIONS
+
+=head2 Why is there Perl source in my database?
+
+If you look at the contents of a database file created by DB_File,
+there can sometimes be part of a Perl script included in it.
+
+This happens because Berkeley DB uses dynamic memory to allocate
+buffers which will subsequently be written to the database file. Being
+dynamic, the memory could have been used for anything before DB
+malloced it. As Berkeley DB doesn't clear the memory once it has been
+allocated, the unused portions will contain random junk. In the case
+where a Perl script gets written to the database, the random junk will
+correspond to an area of dynamic memory that happened to be used during
+the compilation of the script.
+
+Unless you don't like the possibility of there being part of your Perl
+scripts embedded in a database file, this is nothing to worry about.
+
+=head2 How do I store complex data structures with DB_File?
+
+Although B<DB_File> cannot do this directly, there is a module which
+can layer transparently over B<DB_File> to accomplish this feat.
+
+Check out the MLDBM module, available on CPAN in the directory
+F<modules/by-module/MLDBM>.
+
+=head2 What does "Invalid Argument" mean?
+
+You will get this error message when one of the parameters in the
+C<tie> call is wrong. Unfortunately there are quite a few parameters to
+get wrong, so it can be difficult to figure out which one it is.
+
+Here are a couple of possibilities:
+
+=over 5
+
+=item 1.
+
+Attempting to reopen a database without closing it.
+
+=item 2.
+
+Using the O_WRONLY flag.
+
+=back
+
+=head2 What does "Bareword 'DB_File' not allowed" mean?
+
+You will encounter this particular error message when you have the
+C<strict 'subs'> pragma (or the full strict pragma) in your script.
+Consider this script:
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ my %x ;
+ tie %x, DB_File, "filename" ;
+
+Running it produces the error in question:
+
+ Bareword "DB_File" not allowed while "strict subs" in use
+
+To get around the error, place the word C<DB_File> in either single or
+double quotes, like this:
+
+ tie %x, "DB_File", "filename" ;
+
+Although it might seem like a real pain, it is really worth the effort
+of having a C<use strict> in all your scripts.
+
+=head1 REFERENCES
+
+Articles that are either about B<DB_File> or make use of it.
+
+=over 5
+
+=item 1.
+
+I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com),
+Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41
+
+=back
+
+=head1 HISTORY
+
+Moved to the Changes file.
+
+=head1 BUGS
+
+Some older versions of Berkeley DB had problems with fixed length
+records using the RECNO file format. This problem has been fixed since
+version 1.85 of Berkeley DB.
+
+I am sure there are bugs in the code. If you do find any, or can
+suggest any enhancements, I would welcome your comments.
+
+=head1 AVAILABILITY
+
+B<DB_File> comes with the standard Perl source distribution. Look in
+the directory F<ext/DB_File>. Given the amount of time between releases
+of Perl the version that ships with Perl is quite likely to be out of
+date, so the most recent version can always be found on CPAN (see
+L<perlmodlib/CPAN> for details), in the directory
+F<modules/by-module/DB_File>.
+
+This version of B<DB_File> will work with either version 1.x, 2.x or
+3.x of Berkeley DB, but is limited to the functionality provided by
+version 1.
+
+The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+All versions of Berkeley DB are available there.
+
+Alternatively, Berkeley DB version 1 is available at your nearest CPAN
+archive in F<src/misc/db.1.85.tar.gz>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-2007 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.
+
+Here are are few words taken from the Berkeley DB FAQ (at
+F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+
+ Do I have to license DB to use it in Perl scripts?
+
+ 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.
+
+
+=head1 SEE ALSO
+
+L<perl>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<perldbmfilter>
+
+=head1 AUTHOR
+
+The DB_File interface was written by Paul Marquess
+E<lt>pmqs@cpan.orgE<gt>.
+
+=cut
diff --git a/lang/perl/DB_File/DB_File.xs b/lang/perl/DB_File/DB_File.xs
new file mode 100644
index 00000000..e61dc134
--- /dev/null
+++ b/lang/perl/DB_File/DB_File.xs
@@ -0,0 +1,1995 @@
+/*
+
+ DB_File.xs -- Perl 5 interface to Berkeley DB
+
+ written by Paul Marquess <pmqs@cpan.org>
+ last modified 4th February 2007
+ version 1.818
+
+ All comments/suggestions/problems are welcome
+
+ Copyright (c) 1995-2009 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.
+
+ Changes:
+ 0.1 - Initial Release
+ 0.2 - No longer bombs out if dbopen returns an error.
+ 0.3 - Added some support for multiple btree compares
+ 1.0 - Complete support for multiple callbacks added.
+ Fixed a problem with pushing a value onto an empty list.
+ 1.01 - Fixed a SunOS core dump problem.
+ The return value from TIEHASH wasn't set to NULL when
+ dbopen returned an error.
+ 1.02 - Use ALIAS to define TIEARRAY.
+ Removed some redundant commented code.
+ Merged OS2 code into the main distribution.
+ 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
+ 1.06 - Minor namespace cleanup: Localized PrintBtree.
+ 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+ 1.08 - No change to DB_File.xs
+ 1.09 - Default mode for dbopen changed to 0666
+ 1.10 - Fixed fd method so that it still returns -1 for
+ in-memory files when db 1.86 is used.
+ 1.11 - No change to DB_File.xs
+ 1.12 - No change to DB_File.xs
+ 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.50 - Make work with both DB 1.x or DB 2.x
+ 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
+ 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
+ undefined value" warning with db_get and db_seq.
+ 1.53 - Added DB_RENUMBER to flags for recno.
+ 1.54 - Fixed bug in the fd method
+ 1.55 - Fix for AIX from Jarkko Hietaniemi
+ 1.56 - No change to DB_File.xs
+ 1.57 - added the #undef op to allow building with Threads support.
+ 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
+ 1.61 - added flagSet macro for DB 2.5.x
+ fixed typo in O_RDONLY test.
+ 1.62 - No change to DB_File.xs
+ 1.63 - Fix to alllow DB 2.6.x to build.
+ 1.64 - Tidied up the 1.x to 2.x flags mapping code.
+ Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
+ to fix a flag mapping problem with O_RDONLY on the Hurd
+ 1.65 - Fixed a bug in the PUSH logic.
+ Added BOOT check that using 2.3.4 or greater
+ 1.66 - Added DBM filter code
+ 1.67 - Backed off the use of newSVpvn.
+ Fixed DBM Filter code for Perl 5.004.
+ Fixed a small memory leak in the filter code.
+ 1.68 - fixed backward compatibility bug with R_IAFTER & R_IBEFORE
+ merged in the 5.005_58 changes
+ 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly.
+ Fixed the R_SETCURSOR bug introduced in 1.68
+ Added a new Perl variable $DB_File::db_ver
+ 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with
+ GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
+ Added a BOOT check to test for equivalent versions of db.h &
+ libdb.a/so.
+ 1.71 - Support for Berkeley DB version 3.
+ Support for Berkeley DB 2/3's backward compatibility mode.
+ Rewrote push
+ 1.72 - No change to DB_File.xs
+ 1.73 - No change to DB_File.xs
+ 1.74 - A call to open needed parenthesised to stop it clashing
+ with a win32 macro.
+ Added Perl core patches 7703 & 7801.
+ 1.75 - Fixed Perl core patch 7703.
+ Added support to allow DB_File to be built with
+ Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
+ needed to be changed.
+ 1.76 - No change to DB_File.xs
+ 1.77 - Tidied up a few types used in calling newSVpvn.
+ 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 compatibility code into ppport.h.
+ Use the new constants code.
+ 1.801 - No change to DB_File.xs
+ 1.802 - No change to DB_File.xs
+ 1.803 - FETCH, STORE & DELETE don't map the flags parameter
+ into the equivalent Berkeley DB function anymore.
+ 1.804 - no change.
+ 1.805 - recursion detection added to the callbacks
+ Support for 4.1.X added.
+ Filter code can now cope with read-only $_
+ 1.806 - recursion detection beefed up.
+ 1.807 - no change
+ 1.808 - leak fixed in ParseOpenInfo
+ 1.809 - no change
+ 1.810 - no change
+ 1.811 - no change
+ 1.812 - no change
+ 1.813 - no change
+ 1.814 - no change
+ 1.814 - C++ casting fixes
+
+*/
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef _NOT_CORE
+# include "ppport.h"
+#endif
+
+/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and
+ DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */
+
+/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
+ * shortly #included by the <db.h>) __attribute__ to the possibly
+ * already defined __attribute__, for example by GNUC or by Perl. */
+
+/* #if DB_VERSION_MAJOR_CFG < 2 */
+#ifndef DB_VERSION_MAJOR
+# undef __attribute__
+#endif
+
+#ifdef COMPAT185
+# include <db_185.h>
+#else
+# include <db.h>
+#endif
+
+/* Wall starts with 5.7.x */
+
+#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7)
+
+/* Since we dropped the gccish definition of __attribute__ we will want
+ * to redefine dNOOP, however (so that dTHX continues to work). Yes,
+ * all this means that we can't do attribute checking on the DB_File,
+ * boo, hiss. */
+# ifndef DB_VERSION_MAJOR
+
+# undef dNOOP
+# define dNOOP extern int Perl___notused
+
+ /* Ditto for dXSARGS. */
+# undef dXSARGS
+# define dXSARGS \
+ dSP; dMARK; \
+ I32 ax = mark - PL_stack_base + 1; \
+ I32 items = sp - mark
+
+# endif
+
+/* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */
+# undef dXSI32
+# define dXSI32 dNOOP
+
+#endif /* Perl >= 5.7 */
+
+#include <fcntl.h>
+
+/* #define TRACE */
+
+#ifdef TRACE
+# define Trace(x) printf x
+#else
+# define Trace(x)
+#endif
+
+
+#define DBT_clear(x) Zero(&x, 1, DBT) ;
+
+#ifdef DB_VERSION_MAJOR
+
+#if DB_VERSION_MAJOR == 2
+# define BERKELEY_DB_1_OR_2
+#endif
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
+# define AT_LEAST_DB_3_2
+#endif
+
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_3_3
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
+# define AT_LEAST_DB_4_1
+#endif
+
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_4_3
+#endif
+
+#ifdef AT_LEAST_DB_3_3
+# define WANT_ERROR
+#endif
+
+/* map version 2 features & constants onto their version 1 equivalent */
+
+#ifdef DB_Prefix_t
+# undef DB_Prefix_t
+#endif
+#define DB_Prefix_t size_t
+
+#ifdef DB_Hash_t
+# undef DB_Hash_t
+#endif
+#define DB_Hash_t u_int32_t
+
+/* DBTYPE stays the same */
+/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
+#if DB_VERSION_MAJOR == 2
+ typedef DB_INFO INFO ;
+#else /* DB_VERSION_MAJOR > 2 */
+# define DB_FIXEDLEN (0x8000)
+#endif /* DB_VERSION_MAJOR == 2 */
+
+/* version 2 has db_recno_t in place of recno_t */
+typedef db_recno_t recno_t;
+
+
+#define R_CURSOR DB_SET_RANGE
+#define R_FIRST DB_FIRST
+#define R_IAFTER DB_AFTER
+#define R_IBEFORE DB_BEFORE
+#define R_LAST DB_LAST
+#define R_NEXT DB_NEXT
+#define R_NOOVERWRITE DB_NOOVERWRITE
+#define R_PREV DB_PREV
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+# define R_SETCURSOR 0x800000
+#else
+# define R_SETCURSOR (-100)
+#endif
+
+#define R_RECNOSYNC 0
+#define R_FIXEDLEN DB_FIXEDLEN
+#define R_DUP DB_DUP
+
+
+#define db_HA_hash h_hash
+#define db_HA_ffactor h_ffactor
+#define db_HA_nelem h_nelem
+#define db_HA_bsize db_pagesize
+#define db_HA_cachesize db_cachesize
+#define db_HA_lorder db_lorder
+
+#define db_BT_compare bt_compare
+#define db_BT_prefix bt_prefix
+#define db_BT_flags flags
+#define db_BT_psize db_pagesize
+#define db_BT_cachesize db_cachesize
+#define db_BT_lorder db_lorder
+#define db_BT_maxkeypage
+#define db_BT_minkeypage
+
+
+#define db_RE_reclen re_len
+#define db_RE_flags flags
+#define db_RE_bval re_pad
+#define db_RE_bfname re_source
+#define db_RE_psize db_pagesize
+#define db_RE_cachesize db_cachesize
+#define db_RE_lorder db_lorder
+
+#define TXN NULL,
+
+#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
+
+
+#define DBT_flags(x) x.flags = 0
+#define DB_flags(x, v) x |= v
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+# define flagSet(flags, bitmask) ((flags) & (bitmask))
+#else
+# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
+#endif
+
+#else /* db version 1.x */
+
+#define BERKELEY_DB_1
+#define BERKELEY_DB_1_OR_2
+
+typedef union INFO {
+ HASHINFO hash ;
+ RECNOINFO recno ;
+ BTREEINFO btree ;
+ } INFO ;
+
+
+#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
+
+#define db_HA_hash hash.hash
+#define db_HA_ffactor hash.ffactor
+#define db_HA_nelem hash.nelem
+#define db_HA_bsize hash.bsize
+#define db_HA_cachesize hash.cachesize
+#define db_HA_lorder hash.lorder
+
+#define db_BT_compare btree.compare
+#define db_BT_prefix btree.prefix
+#define db_BT_flags btree.flags
+#define db_BT_psize btree.psize
+#define db_BT_cachesize btree.cachesize
+#define db_BT_lorder btree.lorder
+#define db_BT_maxkeypage btree.maxkeypage
+#define db_BT_minkeypage btree.minkeypage
+
+#define db_RE_reclen recno.reclen
+#define db_RE_flags recno.flags
+#define db_RE_bval recno.bval
+#define db_RE_bfname recno.bfname
+#define db_RE_psize recno.psize
+#define db_RE_cachesize recno.cachesize
+#define db_RE_lorder recno.lorder
+
+#define TXN
+
+#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
+#define DBT_flags(x)
+#define DB_flags(x, v)
+#define flagSet(flags, bitmask) ((flags) & (bitmask))
+
+#endif /* db version 1 */
+
+
+
+#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
+#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
+#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
+
+#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
+#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
+
+#ifdef DB_VERSION_MAJOR
+#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
+ (db->dbp->close)(db->dbp, 0) ))
+#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
+#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
+ ? ((db->cursor)->c_del)(db->cursor, 0) \
+ : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
+
+#else /* ! DB_VERSION_MAJOR */
+
+#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
+#define db_close(db) ((db->dbp)->close)(db->dbp)
+#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
+#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
+
+#endif /* ! DB_VERSION_MAJOR */
+
+
+#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
+
+typedef struct {
+ DBTYPE type ;
+ DB * dbp ;
+ SV * compare ;
+ bool in_compare ;
+ SV * prefix ;
+ bool in_prefix ;
+ SV * hash ;
+ bool in_hash ;
+ bool aborted ;
+ int in_memory ;
+#ifdef BERKELEY_DB_1_OR_2
+ INFO info ;
+#endif
+#ifdef DB_VERSION_MAJOR
+ DBC * cursor ;
+#endif
+ SV * filter_fetch_key ;
+ SV * filter_store_key ;
+ SV * filter_fetch_value ;
+ SV * filter_store_value ;
+ int filtering ;
+
+ } DB_File_type;
+
+typedef DB_File_type * DB_File ;
+typedef DBT DBTKEY ;
+
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (const char *)""), s)
+
+#define OutputValue(arg, name) \
+ { if (RETVAL == 0) { \
+ SvGETMAGIC(arg) ; \
+ my_sv_setpvn(arg, (const char *)name.data, name.size) ; \
+ TAINT; \
+ SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
+ DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
+ } \
+ }
+
+#define OutputKey(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ SvGETMAGIC(arg) ; \
+ if (db->type != DB_RECNO) { \
+ my_sv_setpvn(arg, (const char *)name.data, name.size); \
+ } \
+ else \
+ sv_setiv(arg, (I32)*(I32*)name.data - 1); \
+ TAINT; \
+ SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
+ DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
+ } \
+ }
+
+#define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
+
+#ifdef CAN_PROTOTYPE
+extern void __getBerkeleyDBInfo(void);
+#endif
+
+/* Internal Global Data */
+
+#define MY_CXT_KEY "DB_File::_guts" XS_VERSION
+
+typedef struct {
+ recno_t x_Value;
+ recno_t x_zero;
+ DB_File x_CurrentDB;
+ DBTKEY x_empty;
+} my_cxt_t;
+
+START_MY_CXT
+
+#define Value (MY_CXT.x_Value)
+#define zero (MY_CXT.x_zero)
+#define CurrentDB (MY_CXT.x_CurrentDB)
+#define empty (MY_CXT.x_empty)
+
+#define ERR_BUFF "DB_File::Error"
+
+#ifdef DB_VERSION_MAJOR
+
+static int
+#ifdef CAN_PROTOTYPE
+db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
+#else
+db_put(db, key, value, flags)
+DB_File db ;
+DBTKEY key ;
+DBT value ;
+u_int flags ;
+#endif
+{
+ int status ;
+
+ if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
+ DBC * temp_cursor ;
+ DBT l_key, l_value;
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
+ if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
+#else
+ if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
+#endif
+ return (-1) ;
+
+ memset(&l_key, 0, sizeof(l_key));
+ l_key.data = key.data;
+ l_key.size = key.size;
+ memset(&l_value, 0, sizeof(l_value));
+ l_value.data = value.data;
+ l_value.size = value.size;
+
+ if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
+ (void)temp_cursor->c_close(temp_cursor);
+ return (-1);
+ }
+
+ status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
+ (void)temp_cursor->c_close(temp_cursor);
+
+ return (status) ;
+ }
+
+
+ if (flagSet(flags, R_CURSOR)) {
+ return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
+ }
+
+ if (flagSet(flags, R_SETCURSOR)) {
+ if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
+ return -1 ;
+ return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
+
+ }
+
+ return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
+
+}
+
+#endif /* DB_VERSION_MAJOR */
+
+static void
+tidyUp(DB_File db)
+{
+ db->aborted = TRUE ;
+}
+
+
+static int
+#ifdef AT_LEAST_DB_3_2
+
+#ifdef CAN_PROTOTYPE
+btree_compare(DB * db, const DBT *key1, const DBT *key2)
+#else
+btree_compare(db, key1, key2)
+DB * db ;
+const DBT * key1 ;
+const DBT * key2 ;
+#endif /* CAN_PROTOTYPE */
+
+#else /* Berkeley DB < 3.2 */
+
+#ifdef CAN_PROTOTYPE
+btree_compare(const DBT *key1, const DBT *key2)
+#else
+btree_compare(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
+
+#endif
+
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ void * data1, * data2 ;
+ int retval ;
+ int count ;
+
+
+ if (CurrentDB->in_compare) {
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_compare: recursion detected\n") ;
+ }
+
+ data1 = (char *) key1->data ;
+ data2 = (char *) key2->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_compare = FALSE;
+ SAVEINT(CurrentDB->in_compare);
+ CurrentDB->in_compare = TRUE;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->compare, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1){
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
+ }
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+
+}
+
+static DB_Prefix_t
+#ifdef AT_LEAST_DB_3_2
+
+#ifdef CAN_PROTOTYPE
+btree_prefix(DB * db, const DBT *key1, const DBT *key2)
+#else
+btree_prefix(db, key1, key2)
+Db * db ;
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
+
+#else /* Berkeley DB < 3.2 */
+
+#ifdef CAN_PROTOTYPE
+btree_prefix(const DBT *key1, const DBT *key2)
+#else
+btree_prefix(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
+
+#endif
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT ;
+ char * data1, * data2 ;
+ int retval ;
+ int count ;
+
+ if (CurrentDB->in_prefix){
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_prefix: recursion detected\n") ;
+ }
+
+ data1 = (char *) key1->data ;
+ data2 = (char *) key2->data ;
+
+#ifndef newSVpvn
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+#endif
+
+ ENTER ;
+ SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_prefix = FALSE;
+ SAVEINT(CurrentDB->in_prefix);
+ CurrentDB->in_prefix = TRUE;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1){
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
+ }
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+
+#ifdef BERKELEY_DB_1
+# define HASH_CB_SIZE_TYPE size_t
+#else
+# define HASH_CB_SIZE_TYPE u_int32_t
+#endif
+
+static DB_Hash_t
+#ifdef AT_LEAST_DB_3_2
+
+#ifdef CAN_PROTOTYPE
+hash_cb(DB * db, const void *data, u_int32_t size)
+#else
+hash_cb(db, data, size)
+DB * db ;
+const void * data ;
+HASH_CB_SIZE_TYPE size ;
+#endif
+
+#else /* Berkeley DB < 3.2 */
+
+#ifdef CAN_PROTOTYPE
+hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
+#else
+hash_cb(data, size)
+const void * data ;
+HASH_CB_SIZE_TYPE size ;
+#endif
+
+#endif
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ dSP ;
+ dMY_CXT;
+ int retval = 0;
+ int count ;
+
+ if (CurrentDB->in_hash){
+ tidyUp(CurrentDB);
+ croak ("DB_File hash callback: recursion detected\n") ;
+ }
+
+#ifndef newSVpvn
+ if (size == 0)
+ data = "" ;
+#endif
+
+ /* DGH - Next two lines added to fix corrupted stack problem */
+ ENTER ;
+ SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_hash = FALSE;
+ SAVEINT(CurrentDB->in_hash);
+ CurrentDB->in_hash = TRUE;
+
+ PUSHMARK(SP) ;
+
+
+ XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->hash, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1){
+ tidyUp(CurrentDB);
+ croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
+ }
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+#ifdef WANT_ERROR
+
+static void
+#ifdef AT_LEAST_DB_4_3
+db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
+#else
+db_errcall_cb(const char * db_errpfx, char * buffer)
+#endif
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
+ if (sv) {
+ if (db_errpfx)
+ sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
+ else
+ sv_setpv(sv, buffer) ;
+ }
+}
+#endif
+
+#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
+
+static void
+#ifdef CAN_PROTOTYPE
+PrintHash(INFO *hash)
+#else
+PrintHash(hash)
+INFO * hash ;
+#endif
+{
+ printf ("HASH Info\n") ;
+ printf (" hash = %s\n",
+ (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
+ printf (" bsize = %d\n", hash->db_HA_bsize) ;
+ printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
+ printf (" nelem = %d\n", hash->db_HA_nelem) ;
+ printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
+ printf (" lorder = %d\n", hash->db_HA_lorder) ;
+
+}
+
+static void
+#ifdef CAN_PROTOTYPE
+PrintRecno(INFO *recno)
+#else
+PrintRecno(recno)
+INFO * recno ;
+#endif
+{
+ printf ("RECNO Info\n") ;
+ printf (" flags = %d\n", recno->db_RE_flags) ;
+ printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
+ printf (" psize = %d\n", recno->db_RE_psize) ;
+ printf (" lorder = %d\n", recno->db_RE_lorder) ;
+ printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
+ printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
+ printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
+}
+
+static void
+#ifdef CAN_PROTOTYPE
+PrintBtree(INFO *btree)
+#else
+PrintBtree(btree)
+INFO * btree ;
+#endif
+{
+ printf ("BTREE Info\n") ;
+ printf (" compare = %s\n",
+ (btree->db_BT_compare ? "redefined" : "default")) ;
+ printf (" prefix = %s\n",
+ (btree->db_BT_prefix ? "redefined" : "default")) ;
+ printf (" flags = %d\n", btree->db_BT_flags) ;
+ printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
+ printf (" psize = %d\n", btree->db_BT_psize) ;
+#ifndef DB_VERSION_MAJOR
+ printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
+ printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
+#endif
+ printf (" lorder = %d\n", btree->db_BT_lorder) ;
+}
+
+#else
+
+#define PrintRecno(recno)
+#define PrintHash(hash)
+#define PrintBtree(btree)
+
+#endif /* TRACE */
+
+
+static I32
+#ifdef CAN_PROTOTYPE
+GetArrayLength(pTHX_ DB_File db)
+#else
+GetArrayLength(db)
+DB_File db ;
+#endif
+{
+ DBT key ;
+ DBT value ;
+ int RETVAL ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ if (RETVAL == 0)
+ RETVAL = *(I32 *)key.data ;
+ else /* No key means empty file */
+ RETVAL = 0 ;
+
+ return ((I32)RETVAL) ;
+}
+
+static recno_t
+#ifdef CAN_PROTOTYPE
+GetRecnoKey(pTHX_ DB_File db, I32 value)
+#else
+GetRecnoKey(db, value)
+DB_File db ;
+I32 value ;
+#endif
+{
+ if (value < 0) {
+ /* Get the length of the array */
+ I32 length = GetArrayLength(aTHX_ db) ;
+
+ /* check for attempt to write before start of array */
+ if (length + value + 1 <= 0) {
+ tidyUp(db);
+ croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
+ }
+
+ value = length + value + 1 ;
+ }
+ else
+ ++ value ;
+
+ return value ;
+}
+
+
+static DB_File
+#ifdef CAN_PROTOTYPE
+ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
+#else
+ParseOpenInfo(isHASH, name, flags, mode, sv)
+int isHASH ;
+char * name ;
+int flags ;
+int mode ;
+SV * sv ;
+#endif
+{
+
+#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */
+
+ SV ** svp;
+ HV * action ;
+ DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
+ void * openinfo = NULL ;
+ INFO * info = &RETVAL->info ;
+ STRLEN n_a;
+ dMY_CXT;
+
+#ifdef TRACE
+ printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",
+ name, flags, mode, sv == NULL) ;
+#endif
+ Zero(RETVAL, 1, DB_File_type) ;
+
+ /* Default to HASH */
+ RETVAL->filtering = 0 ;
+ RETVAL->filter_fetch_key = RETVAL->filter_store_key =
+ RETVAL->filter_fetch_value = RETVAL->filter_store_value =
+ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
+ RETVAL->type = DB_HASH ;
+
+ /* DGH - Next line added to avoid SEGV on existing hash DB */
+ CurrentDB = RETVAL;
+
+ /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
+ RETVAL->in_memory = (name == NULL) ;
+
+ if (sv)
+ {
+ if (! SvROK(sv) )
+ croak ("type parameter is not a reference") ;
+
+ svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
+ if (svp && SvOK(*svp))
+ action = (HV*) SvRV(*svp) ;
+ else
+ croak("internal error") ;
+
+ if (sv_isa(sv, "DB_File::HASHINFO"))
+ {
+
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_HASH database") ;
+
+ RETVAL->type = DB_HASH ;
+ openinfo = (void*)info ;
+
+ svp = hv_fetch(action, "hash", 4, FALSE);
+
+ if (svp && SvOK(*svp))
+ {
+ info->db_HA_hash = hash_cb ;
+ RETVAL->hash = newSVsv(*svp) ;
+ }
+ else
+ info->db_HA_hash = NULL ;
+
+ svp = hv_fetch(action, "ffactor", 7, FALSE);
+ info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "nelem", 5, FALSE);
+ info->db_HA_nelem = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "bsize", 5, FALSE);
+ info->db_HA_bsize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_HA_lorder = svp ? SvIV(*svp) : 0;
+
+ PrintHash(info) ;
+ }
+ else if (sv_isa(sv, "DB_File::BTREEINFO"))
+ {
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_BTREE database");
+
+ RETVAL->type = DB_BTREE ;
+ openinfo = (void*)info ;
+
+ svp = hv_fetch(action, "compare", 7, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ info->db_BT_compare = btree_compare ;
+ RETVAL->compare = newSVsv(*svp) ;
+ }
+ else
+ info->db_BT_compare = NULL ;
+
+ svp = hv_fetch(action, "prefix", 6, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ info->db_BT_prefix = btree_prefix ;
+ RETVAL->prefix = newSVsv(*svp) ;
+ }
+ else
+ info->db_BT_prefix = NULL ;
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ info->db_BT_flags = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
+
+#ifndef DB_VERSION_MAJOR
+ svp = hv_fetch(action, "minkeypage", 10, FALSE);
+ info->btree.minkeypage = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "maxkeypage", 10, FALSE);
+ info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
+#endif
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ info->db_BT_psize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_BT_lorder = svp ? SvIV(*svp) : 0;
+
+ PrintBtree(info) ;
+
+ }
+ else if (sv_isa(sv, "DB_File::RECNOINFO"))
+ {
+ if (isHASH)
+ croak("DB_File can only tie an array to a DB_RECNO database");
+
+ RETVAL->type = DB_RECNO ;
+ openinfo = (void *)info ;
+
+ info->db_RE_flags = 0 ;
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "reclen", 6, FALSE);
+ info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
+
+#ifdef DB_VERSION_MAJOR
+ info->re_source = name ;
+ name = NULL ;
+#endif
+ svp = hv_fetch(action, "bfname", 6, FALSE);
+ if (svp && SvOK(*svp)) {
+ char * ptr = SvPV(*svp,n_a) ;
+#ifdef DB_VERSION_MAJOR
+ name = (char*) n_a ? ptr : NULL ;
+#else
+ info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
+#endif
+ }
+ else
+#ifdef DB_VERSION_MAJOR
+ name = NULL ;
+#else
+ info->db_RE_bfname = NULL ;
+#endif
+
+ svp = hv_fetch(action, "bval", 4, FALSE);
+#ifdef DB_VERSION_MAJOR
+ if (svp && SvOK(*svp))
+ {
+ int value ;
+ if (SvPOK(*svp))
+ value = (int)*SvPV(*svp, n_a) ;
+ else
+ value = SvIV(*svp) ;
+
+ if (info->flags & DB_FIXEDLEN) {
+ info->re_pad = value ;
+ info->flags |= DB_PAD ;
+ }
+ else {
+ info->re_delim = value ;
+ info->flags |= DB_DELIMITER ;
+ }
+
+ }
+#else
+ if (svp && SvOK(*svp))
+ {
+ if (SvPOK(*svp))
+ info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
+ else
+ info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
+ DB_flags(info->flags, DB_DELIMITER) ;
+
+ }
+ else
+ {
+ if (info->db_RE_flags & R_FIXEDLEN)
+ info->db_RE_bval = (u_char) ' ' ;
+ else
+ info->db_RE_bval = (u_char) '\n' ;
+ DB_flags(info->flags, DB_DELIMITER) ;
+ }
+#endif
+
+#ifdef DB_RENUMBER
+ info->flags |= DB_RENUMBER ;
+#endif
+
+ PrintRecno(info) ;
+ }
+ else
+ croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
+ }
+
+
+ /* OS2 Specific Code */
+#ifdef OS2
+#ifdef __EMX__
+ flags |= O_BINARY;
+#endif /* __EMX__ */
+#endif /* OS2 */
+
+#ifdef DB_VERSION_MAJOR
+
+ {
+ int Flags = 0 ;
+ int status ;
+
+ /* Map 1.x flags to 2.x flags */
+ if ((flags & O_CREAT) == O_CREAT)
+ Flags |= DB_CREATE ;
+
+#if O_RDONLY == 0
+ if (flags == O_RDONLY)
+#else
+ if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
+#endif
+ Flags |= DB_RDONLY ;
+
+#ifdef O_TRUNC
+ if ((flags & O_TRUNC) == O_TRUNC)
+ Flags |= DB_TRUNCATE ;
+#endif
+
+ status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ;
+ if (status == 0)
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
+#else
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
+ 0) ;
+#endif
+
+ if (status)
+ RETVAL->dbp = NULL ;
+
+ }
+#else
+
+#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
+ RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
+#else
+ RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
+#endif /* DB_LIBRARY_COMPATIBILITY_API */
+
+#endif
+
+ return (RETVAL) ;
+
+#else /* Berkeley DB Version > 2 */
+
+ SV ** svp;
+ HV * action ;
+ DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
+ DB * dbp ;
+ STRLEN n_a;
+ int status ;
+ dMY_CXT;
+
+/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
+ Zero(RETVAL, 1, DB_File_type) ;
+
+ /* Default to HASH */
+ RETVAL->filtering = 0 ;
+ RETVAL->filter_fetch_key = RETVAL->filter_store_key =
+ RETVAL->filter_fetch_value = RETVAL->filter_store_value =
+ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
+ RETVAL->type = DB_HASH ;
+
+ /* DGH - Next line added to avoid SEGV on existing hash DB */
+ CurrentDB = RETVAL;
+
+ /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
+ RETVAL->in_memory = (name == NULL) ;
+
+ status = db_create(&RETVAL->dbp, NULL,0) ;
+ /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
+ if (status) {
+ RETVAL->dbp = NULL ;
+ return (RETVAL) ;
+ }
+ dbp = RETVAL->dbp ;
+
+#ifdef WANT_ERROR
+ RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
+#endif
+ if (sv)
+ {
+ if (! SvROK(sv) )
+ croak ("type parameter is not a reference") ;
+
+ svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
+ if (svp && SvOK(*svp))
+ action = (HV*) SvRV(*svp) ;
+ else
+ croak("internal error") ;
+
+ if (sv_isa(sv, "DB_File::HASHINFO"))
+ {
+
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_HASH database") ;
+
+ RETVAL->type = DB_HASH ;
+
+ svp = hv_fetch(action, "hash", 4, FALSE);
+
+ if (svp && SvOK(*svp))
+ {
+ (void)dbp->set_h_hash(dbp, hash_cb) ;
+ RETVAL->hash = newSVsv(*svp) ;
+ }
+
+ svp = hv_fetch(action, "ffactor", 7, FALSE);
+ if (svp)
+ (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ;
+
+ svp = hv_fetch(action, "nelem", 5, FALSE);
+ if (svp)
+ (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ;
+
+ svp = hv_fetch(action, "bsize", 5, FALSE);
+ if (svp)
+ (void)dbp->set_pagesize(dbp, my_SvUV32(*svp));
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ if (svp)
+ (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ if (svp)
+ (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
+
+ PrintHash(info) ;
+ }
+ else if (sv_isa(sv, "DB_File::BTREEINFO"))
+ {
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_BTREE database");
+
+ RETVAL->type = DB_BTREE ;
+
+ svp = hv_fetch(action, "compare", 7, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ (void)dbp->set_bt_compare(dbp, btree_compare) ;
+ RETVAL->compare = newSVsv(*svp) ;
+ }
+
+ svp = hv_fetch(action, "prefix", 6, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ (void)dbp->set_bt_prefix(dbp, btree_prefix) ;
+ RETVAL->prefix = newSVsv(*svp) ;
+ }
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ if (svp)
+ (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ;
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ if (svp)
+ (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ if (svp)
+ (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ if (svp)
+ (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
+
+ PrintBtree(info) ;
+
+ }
+ else if (sv_isa(sv, "DB_File::RECNOINFO"))
+ {
+ int fixed = FALSE ;
+
+ if (isHASH)
+ croak("DB_File can only tie an array to a DB_RECNO database");
+
+ RETVAL->type = DB_RECNO ;
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ if (svp) {
+ int flags = SvIV(*svp) ;
+ /* remove FIXDLEN, if present */
+ if (flags & DB_FIXEDLEN) {
+ fixed = TRUE ;
+ flags &= ~DB_FIXEDLEN ;
+ }
+ }
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ if (svp) {
+ status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ;
+ }
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ if (svp) {
+ status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ;
+ }
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ if (svp) {
+ status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ;
+ }
+
+ svp = hv_fetch(action, "bval", 4, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ int value ;
+ if (SvPOK(*svp))
+ value = (int)*SvPV(*svp, n_a) ;
+ else
+ value = (int)SvIV(*svp) ;
+
+ if (fixed) {
+ status = dbp->set_re_pad(dbp, value) ;
+ }
+ else {
+ status = dbp->set_re_delim(dbp, value) ;
+ }
+
+ }
+
+ if (fixed) {
+ svp = hv_fetch(action, "reclen", 6, FALSE);
+ if (svp) {
+ u_int32_t len = my_SvUV32(*svp) ;
+ status = dbp->set_re_len(dbp, len) ;
+ }
+ }
+
+ if (name != NULL) {
+ status = dbp->set_re_source(dbp, name) ;
+ name = NULL ;
+ }
+
+ svp = hv_fetch(action, "bfname", 6, FALSE);
+ if (svp && SvOK(*svp)) {
+ char * ptr = SvPV(*svp,n_a) ;
+ name = (char*) n_a ? ptr : NULL ;
+ }
+ else
+ name = NULL ;
+
+
+ status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ;
+
+ if (flags){
+ (void)dbp->set_flags(dbp, (u_int32_t)flags) ;
+ }
+ PrintRecno(info) ;
+ }
+ else
+ croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
+ }
+
+ {
+ u_int32_t Flags = 0 ;
+ int status ;
+
+ /* Map 1.x flags to 3.x flags */
+ if ((flags & O_CREAT) == O_CREAT)
+ Flags |= DB_CREATE ;
+
+#if O_RDONLY == 0
+ if (flags == O_RDONLY)
+#else
+ if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
+#endif
+ Flags |= DB_RDONLY ;
+
+#ifdef O_TRUNC
+ if ((flags & O_TRUNC) == O_TRUNC)
+ Flags |= DB_TRUNCATE ;
+#endif
+
+#ifdef AT_LEAST_DB_4_4
+ /* need this for recno */
+ if ((flags & O_TRUNC) == O_TRUNC)
+ Flags |= DB_CREATE ;
+#endif
+
+#ifdef AT_LEAST_DB_4_1
+ status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
+ Flags, mode) ;
+#else
+ status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
+ Flags, mode) ;
+#endif
+ /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
+
+ if (status == 0) {
+
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
+ 0) ;
+ /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
+ }
+
+ if (status)
+ RETVAL->dbp = NULL ;
+
+ }
+
+ return (RETVAL) ;
+
+#endif /* Berkeley DB Version > 2 */
+
+} /* ParseOpenInfo */
+
+
+#include "constants.h"
+
+MODULE = DB_File PACKAGE = DB_File PREFIX = db_
+
+INCLUDE: constants.xs
+
+BOOT:
+ {
+#ifdef dTHX
+ dTHX;
+#endif
+#ifdef WANT_ERROR
+ SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
+#endif
+ MY_CXT_INIT;
+ __getBerkeleyDBInfo() ;
+
+ DBT_clear(empty) ;
+ empty.data = &zero ;
+ empty.size = sizeof(recno_t) ;
+ }
+
+
+
+DB_File
+db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
+ int isHASH
+ char * dbtype
+ int flags
+ int mode
+ CODE:
+ {
+ char * name = (char *) NULL ;
+ SV * sv = (SV *) NULL ;
+ STRLEN n_a;
+
+ if (items >= 3 && SvOK(ST(2)))
+ name = (char*) SvPV(ST(2), n_a) ;
+
+ if (items == 6)
+ sv = ST(5) ;
+
+ RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
+ if (RETVAL->dbp == NULL) {
+ Safefree(RETVAL);
+ RETVAL = NULL ;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+int
+db_DESTROY(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ CurrentDB = db ;
+ Trace(("DESTROY %p\n", db));
+ CLEANUP:
+ Trace(("DESTROY %p done\n", db));
+ if (db->hash)
+ SvREFCNT_dec(db->hash) ;
+ if (db->compare)
+ SvREFCNT_dec(db->compare) ;
+ if (db->prefix)
+ SvREFCNT_dec(db->prefix) ;
+ if (db->filter_fetch_key)
+ SvREFCNT_dec(db->filter_fetch_key) ;
+ if (db->filter_store_key)
+ SvREFCNT_dec(db->filter_store_key) ;
+ if (db->filter_fetch_value)
+ SvREFCNT_dec(db->filter_fetch_value) ;
+ if (db->filter_store_value)
+ SvREFCNT_dec(db->filter_store_value) ;
+ safefree(db) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+#endif
+
+
+int
+db_DELETE(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ CurrentDB = db ;
+
+
+int
+db_EXISTS(db, key)
+ DB_File db
+ DBTKEY key
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DBT value ;
+
+ DBT_clear(value) ;
+ CurrentDB = db ;
+ RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
+ }
+ OUTPUT:
+ RETVAL
+
+void
+db_FETCH(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ PREINIT:
+ dMY_CXT ;
+ int RETVAL ;
+ CODE:
+ {
+ DBT value ;
+
+ DBT_clear(value) ;
+ CurrentDB = db ;
+ RETVAL = db_get(db, key, value, flags) ;
+ ST(0) = sv_newmortal();
+ OutputValue(ST(0), value)
+ }
+
+int
+db_STORE(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ INIT:
+ CurrentDB = db ;
+
+
+void
+db_FIRSTKEY(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT ;
+ int RETVAL ;
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ CurrentDB = db ;
+ RETVAL = do_SEQ(db, key, value, R_FIRST) ;
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key) ;
+ }
+
+void
+db_NEXTKEY(db, key)
+ DB_File db
+ DBTKEY key = NO_INIT
+ PREINIT:
+ dMY_CXT ;
+ int RETVAL ;
+ CODE:
+ {
+ DBT value ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ CurrentDB = db ;
+ RETVAL = do_SEQ(db, key, value, R_NEXT) ;
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key) ;
+ }
+
+#
+# These would be nice for RECNO
+#
+
+int
+unshift(db, ...)
+ DB_File db
+ ALIAS: UNSHIFT = 1
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ int i ;
+ int One ;
+ STRLEN n_a;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ CurrentDB = db ;
+#ifdef DB_VERSION_MAJOR
+ /* get the first value */
+ RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
+ RETVAL = 0 ;
+#else
+ RETVAL = -1 ;
+#endif
+ for (i = items-1 ; i > 0 ; --i)
+ {
+ DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+ value.data = SvPVbyte(ST(i), n_a) ;
+ value.size = n_a ;
+ One = 1 ;
+ key.data = &One ;
+ key.size = sizeof(int) ;
+#ifdef DB_VERSION_MAJOR
+ RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
+#else
+ RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ;
+#endif
+ if (RETVAL != 0)
+ break;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+void
+pop(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT;
+ ALIAS: POP = 1
+ PREINIT:
+ I32 RETVAL;
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ CurrentDB = db ;
+
+ /* First get the final value */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ ST(0) = sv_newmortal();
+ /* Now delete it */
+ if (RETVAL == 0)
+ {
+ /* the call to del will trash value, so take a copy now */
+ OutputValue(ST(0), value) ;
+ RETVAL = db_del(db, key, R_CURSOR) ;
+ if (RETVAL != 0)
+ sv_setsv(ST(0), &PL_sv_undef);
+ }
+ }
+
+void
+shift(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT;
+ ALIAS: SHIFT = 1
+ PREINIT:
+ I32 RETVAL;
+ CODE:
+ {
+ DBT value ;
+ DBTKEY key ;
+
+ DBT_clear(key) ;
+ DBT_clear(value) ;
+ CurrentDB = db ;
+ /* get the first value */
+ RETVAL = do_SEQ(db, key, value, R_FIRST) ;
+ ST(0) = sv_newmortal();
+ /* Now delete it */
+ if (RETVAL == 0)
+ {
+ /* the call to del will trash value, so take a copy now */
+ OutputValue(ST(0), value) ;
+ RETVAL = db_del(db, key, R_CURSOR) ;
+ if (RETVAL != 0)
+ sv_setsv (ST(0), &PL_sv_undef) ;
+ }
+ }
+
+
+I32
+push(db, ...)
+ DB_File db
+ PREINIT:
+ dMY_CXT;
+ ALIAS: PUSH = 1
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ DB * Db = db->dbp ;
+ int i ;
+ STRLEN n_a;
+ int keyval ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ /* Set the Cursor to the Last element */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+#ifndef DB_VERSION_MAJOR
+ if (RETVAL >= 0)
+#endif
+ {
+ if (RETVAL == 0)
+ keyval = *(int*)key.data ;
+ else
+ keyval = 0 ;
+ for (i = 1 ; i < items ; ++i)
+ {
+ DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+ value.data = SvPVbyte(ST(i), n_a) ;
+ value.size = n_a ;
+ ++ keyval ;
+ key.data = &keyval ;
+ key.size = sizeof(int) ;
+ RETVAL = (Db->put)(Db, TXN &key, &value, 0) ;
+ if (RETVAL != 0)
+ break;
+ }
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+I32
+length(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT;
+ ALIAS: FETCHSIZE = 1
+ CODE:
+ CurrentDB = db ;
+ RETVAL = GetArrayLength(aTHX_ db) ;
+ OUTPUT:
+ RETVAL
+
+
+#
+# Now provide an interface to the rest of the DB functionality
+#
+
+int
+db_del(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_del(db, key, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+db_get(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value = NO_INIT
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ CurrentDB = db ;
+ DBT_clear(value) ;
+ RETVAL = db_get(db, key, value, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ value
+
+int
+db_put(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_put(db, key, value, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_KEYEXIST)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
+
+int
+db_fd(db)
+ DB_File db
+ PREINIT:
+ dMY_CXT ;
+ CODE:
+ CurrentDB = db ;
+#ifdef DB_VERSION_MAJOR
+ RETVAL = -1 ;
+ {
+ int status = 0 ;
+ status = (db->in_memory
+ ? -1
+ : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
+ if (status != 0)
+ RETVAL = -1 ;
+ }
+#else
+ RETVAL = (db->in_memory
+ ? -1
+ : ((db->dbp)->fd)(db->dbp) ) ;
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+db_sync(db, flags=0)
+ DB_File db
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_sync(db, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+db_seq(db, key, value, flags)
+ DB_File db
+ DBTKEY key
+ DBT value = NO_INIT
+ u_int flags
+ PREINIT:
+ dMY_CXT;
+ CODE:
+ CurrentDB = db ;
+ DBT_clear(value) ;
+ RETVAL = db_seq(db, key, value, flags);
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ key
+ value
+
+SV *
+filter_fetch_key(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_fetch_key, code) ;
+
+SV *
+filter_store_key(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_store_key, code) ;
+
+SV *
+filter_fetch_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_fetch_value, code) ;
+
+SV *
+filter_store_value(db, code)
+ DB_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ CODE:
+ DBM_setFilter(db->filter_store_value, code) ;
+
diff --git a/lang/perl/DB_File/DB_File_BS b/lang/perl/DB_File/DB_File_BS
new file mode 100644
index 00000000..9282c498
--- /dev/null
+++ b/lang/perl/DB_File/DB_File_BS
@@ -0,0 +1,6 @@
+# NeXT needs /usr/lib/libposix.a to load along with DB_File.so
+if ( $dlsrc eq "dl_next.xs" ) {
+ @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' );
+}
+
+1;
diff --git a/lang/perl/DB_File/MANIFEST b/lang/perl/DB_File/MANIFEST
new file mode 100644
index 00000000..20b3973a
--- /dev/null
+++ b/lang/perl/DB_File/MANIFEST
@@ -0,0 +1,32 @@
+Changes
+DB_File.pm
+DB_File.xs
+DB_File_BS
+MANIFEST
+Makefile.PL
+README
+config.in
+dbinfo
+fallback.h
+fallback.xs
+hints/dynixptx.pl
+hints/sco.pl
+patches/5.004
+patches/5.004_01
+patches/5.004_02
+patches/5.004_03
+patches/5.004_04
+patches/5.004_05
+patches/5.005
+patches/5.005_01
+patches/5.005_02
+patches/5.005_03
+patches/5.6.0
+ppport.h
+t/db-btree.t
+t/db-hash.t
+t/db-recno.t
+t/pod.t
+typemap
+version.c
+META.yml Module meta-data (added by MakeMaker)
diff --git a/lang/perl/DB_File/META.yml b/lang/perl/DB_File/META.yml
new file mode 100644
index 00000000..2981b68b
--- /dev/null
+++ b/lang/perl/DB_File/META.yml
@@ -0,0 +1,21 @@
+--- #YAML:1.0
+name: DB_File
+version: 1.824
+abstract: Perl5 access to Berkeley DB version 1.x
+author:
+ - Paul Marquess <pmqs@cpan.org>
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires: {}
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.54
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
diff --git a/lang/perl/DB_File/Makefile.PL b/lang/perl/DB_File/Makefile.PL
new file mode 100644
index 00000000..a586a044
--- /dev/null
+++ b/lang/perl/DB_File/Makefile.PL
@@ -0,0 +1,358 @@
+#! perl -w
+
+use strict ;
+use ExtUtils::MakeMaker 5.16 ;
+use Config ;
+
+die "DB_File needs Perl 5.004_05 or better. This is $]\n"
+ if $] <= 5.00404;
+
+my $VER_INFO ;
+my $LIB_DIR ;
+my $INC_DIR ;
+my $DB_NAME ;
+my $LIBS ;
+my $COMPAT185 = "" ;
+
+ParseCONFIG() ;
+
+my @files = ('DB_File.pm', glob "t/*.t") ;
+UpDowngrade(@files);
+
+if (defined $DB_NAME)
+ { $LIBS = $DB_NAME }
+else {
+ if ($^O eq 'MSWin32')
+ { $LIBS = $Config{cc} =~ /gcc/ ? '-ldb' : '-llibdb' }
+ else
+ { $LIBS = '-ldb' }
+}
+
+# Solaris is special.
+#$LIBS .= " -lthread" if $^O eq 'solaris' ;
+
+# AIX is special.
+$LIBS .= " -lpthread" if $^O eq 'aix' ;
+
+# OS2 is a special case, so check for it now.
+my $OS2 = "" ;
+$OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ;
+
+my $WALL = '' ;
+#$WALL = ' -Wall ';
+
+WriteMakefile(
+ NAME => 'DB_File',
+ LIBS => ["-L${LIB_DIR} $LIBS"],
+ INC => "-I$INC_DIR",
+ VERSION_FROM => 'DB_File.pm',
+ XS_VERSION => eval MM->parse_version('DB_File.pm'),
+ XSPROTOARG => '-noprototypes',
+ DEFINE => "-D_NOT_CORE $OS2 $VER_INFO $COMPAT185 $WALL",
+ OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)',
+ ((ExtUtils::MakeMaker->VERSION() gt '6.30')
+ ? ('LICENSE' => 'perl')
+ : ()
+ ),
+ (
+ $] >= 5.005
+ ? (ABSTRACT_FROM => 'DB_File.pm',
+ AUTHOR => 'Paul Marquess <pmqs@cpan.org>')
+ : ()
+ ),
+
+
+ #OPTIMIZE => '-g',
+ 'depend' => { 'Makefile' => 'config.in',
+ 'version$(OBJ_EXT)' => 'version.c'},
+ 'clean' => { FILES => 'constants.h constants.xs' },
+ 'macro' => { INSTALLDIRS => 'perl', my_files => "@files" },
+ 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz',
+ DIST_DEFAULT => 'MyDoubleCheck tardist'},
+ );
+
+
+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
+ );
+
+if (eval {require ExtUtils::Constant; 1}) {
+ # 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" ;
+ }
+
+
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'DB_File',
+ NAMES => \@names,
+ C_FILE => 'constants.h',
+ XS_FILE => 'constants.xs',
+
+ );
+}
+else {
+ use File::Copy;
+ copy ('fallback.h', 'constants.h')
+ or die "Can't copy fallback.h to constants.h: $!";
+ copy ('fallback.xs', 'constants.xs')
+ or die "Can't copy fallback.xs to constants.xs: $!";
+}
+
+exit;
+
+
+sub MY::libscan
+{
+ my $self = shift ;
+ my $path = shift ;
+
+ return undef
+ if $path =~ /(~|\.bak)$/ ||
+ $path =~ /^\..*\.swp$/ ;
+
+ return $path;
+}
+
+
+sub MY::postamble { <<'EOM' } ;
+
+MyDoubleCheck:
+ @echo Checking config.in is setup for a release
+ @(grep "^LIB.*/usr/local/BerkeleyDB" config.in && \
+ grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in && \
+ grep "^#DBNAME.*" config.in) >/dev/null || \
+ (echo config.in needs fixing ; exit 1)
+ @echo config.in is ok
+ @echo
+ @echo Checking DB_File.xs is ok for a release.
+ @(perl -ne ' exit 1 if /^\s*#\s*define\s+TRACE/ ; ' DB_File.xs || \
+ (echo DB_File.xs needs fixing ; exit 1))
+ @echo DB_File.xs is ok
+ @echo
+ @echo Checking for $$^W in files: $(my_files)
+ @perl -ne ' \
+ exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \
+ (echo found unexpected $$^W ; exit 1)
+ @echo No $$^W found.
+ @echo
+ @echo Checking for 'use vars' in files: $(my_files)
+ @perl -ne ' \
+ exit 0 if /^__(DATA|END)__/; \
+ exit 1 if /^\s*use\s+vars/;' $(my_files) || \
+ (echo found unexpected "use vars"; exit 1)
+ @echo No 'use vars' found.
+ @echo
+ @echo All files are OK for a release.
+ @echo
+
+EOM
+
+
+
+sub ParseCONFIG
+{
+ my ($k, $v) ;
+ my @badkey = () ;
+ my %Info = () ;
+ my @Options = qw( INCLUDE LIB PREFIX HASH DBNAME COMPAT185 ) ;
+ my %ValidOption = map {$_, 1} @Options ;
+ my %Parsed = %ValidOption ;
+ my $CONFIG = 'config.in' ;
+
+ print "Parsing $CONFIG...\n" ;
+
+ # DBNAME & COMPAT185 are optional, so pretend they have
+ # been parsed.
+ delete $Parsed{'DBNAME'} ;
+ delete $Parsed{'COMPAT185'} ;
+ $Info{COMPAT185} = "No" ;
+
+
+ open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ;
+ while (<F>) {
+ s/^\s*|\s*$//g ;
+ next if /^\s*$/ or /^\s*#/ ;
+ s/\s*#\s*$// ;
+
+ ($k, $v) = split(/\s+=\s+/, $_, 2) ;
+ $k = uc $k ;
+ if ($ValidOption{$k}) {
+ delete $Parsed{$k} ;
+ $Info{$k} = $v ;
+ }
+ else {
+ push(@badkey, $k) ;
+ }
+ }
+ close F ;
+
+ print "Unknown keys in $CONFIG ignored [@badkey]\n"
+ if @badkey ;
+
+ # check parsed values
+ my @missing = () ;
+ die "The following keys are missing from $CONFIG file: [@missing]\n"
+ if @missing = keys %Parsed ;
+
+ $INC_DIR = $ENV{'DB_FILE_INCLUDE'} || $Info{'INCLUDE'} ;
+ $LIB_DIR = $ENV{'DB_FILE_LIB'} || $Info{'LIB'} ;
+ $DB_NAME = $ENV{'DB_FILE_NAME'} || $Info{'DBNAME'} ;
+ $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API"
+ if (defined $ENV{'DB_FILE_COMPAT185'} &&
+ $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) ||
+ $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ;
+ my $PREFIX = $Info{'PREFIX'} ;
+ my $HASH = $Info{'HASH'} ;
+
+ $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ;
+
+ print <<EOM if 0 ;
+ INCLUDE [$INC_DIR]
+ LIB [$LIB_DIR]
+ HASH [$HASH]
+ PREFIX [$PREFIX]
+ DBNAME [$DB_NAME]
+
+EOM
+
+ print "Looks Good.\n" ;
+
+}
+
+sub UpDowngrade
+{
+ my @files = @_ ;
+
+ # our is stable from 5.6.0 onward
+ # warnings is stable from 5.6.1 onward
+
+ # Note: this code assumes that each statement it modifies is not
+ # split across multiple lines.
+
+
+ my $warn_sub ;
+ my $our_sub ;
+
+ if ($] < 5.006001) {
+ # From: use|no warnings "blah"
+ # To: local ($^W) = 1; # use|no warnings "blah"
+ #
+ # and
+ #
+ # From: warnings::warnif(x,y);
+ # To: $^W && carp(y); # warnif -- x
+ $warn_sub = sub {
+ s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
+ s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
+
+ s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ;
+ };
+ }
+ else {
+ # From: local ($^W) = 1; # use|no warnings "blah"
+ # To: use|no warnings "blah"
+ #
+ # and
+ #
+ # From: $^W && carp(y); # warnif -- x
+ # To: warnings::warnif(x,y);
+ $warn_sub = sub {
+ s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+ s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ;
+ };
+ }
+
+ if ($] < 5.006000) {
+ $our_sub = sub {
+ if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
+ my $indent = $1;
+ my $vars = join ' ', split /\s*,\s*/, $2;
+ $_ = "${indent}use vars qw($vars);\n";
+ }
+ };
+ }
+ else {
+ $our_sub = sub {
+ if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
+ my $indent = $1;
+ my $vars = join ', ', split ' ', $2;
+ $_ = "${indent}our ($vars);\n";
+ }
+ };
+ }
+
+ foreach (@files)
+ { doUpDown($our_sub, $warn_sub, $_) }
+}
+
+
+sub doUpDown
+{
+ my $our_sub = shift;
+ my $warn_sub = shift;
+
+ local ($^I) = ".bak" ;
+ local (@ARGV) = shift;
+
+ while (<>)
+ {
+ print, last if /^__(END|DATA)__/ ;
+
+ &{ $our_sub }();
+ &{ $warn_sub }();
+ print ;
+ }
+
+ return if eof ;
+
+ while (<>)
+ { print }
+}
+
+# end of file Makefile.PL
diff --git a/lang/perl/DB_File/README b/lang/perl/DB_File/README
new file mode 100644
index 00000000..719b96e1
--- /dev/null
+++ b/lang/perl/DB_File/README
@@ -0,0 +1,585 @@
+ DB_File
+
+ Version 1.824
+
+ 6th August 2011
+
+ Copyright (c) 1995-2011 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.
+
+
+IMPORTANT NOTICE
+================
+
+If are using the locking technique described in older versions of
+DB_File, please read the section called "Locking: The Trouble with fd"
+in DB_File.pm immediately. The locking method has been found to be
+unsafe. You risk corrupting your data if you continue to use it.
+
+DESCRIPTION
+-----------
+
+DB_File is a module which allows Perl programs to make use of the
+facilities provided by Berkeley DB version 1. (DB_File can be built
+version 2, 3 or 4 of Berkeley DB, but it will only support the 1.x
+features),
+
+If you want to make use of the new features available in Berkeley DB
+2.x, 3.x or 4.x, use the Perl module BerkeleyDB instead.
+
+Berkeley DB is a C library which provides a consistent interface to a
+number of database formats. DB_File provides an interface to all three
+of the database types (hash, btree and recno) currently supported by
+Berkeley DB.
+
+For further details see the documentation included at the end of the
+file DB_File.pm.
+
+PREREQUISITES
+-------------
+
+Before you can build DB_File you must have the following installed on
+your system:
+
+ * Perl 5.004_05 or greater.
+
+ * Berkeley DB.
+
+ The official web site for Berkeley DB is
+
+ http://www.oracle.com/technology/products/berkeley-db/db/index.html
+
+ The latest version of Berkeley DB is always available there. It
+ is recommended that you use the most recent version available.
+
+ The one exception to this advice is where you want to use DB_File
+ to access database files created by a third-party application, like
+ Sendmail or Netscape. In these cases you must build DB_File with a
+ compatible version of Berkeley DB.
+
+ If you want to use Berkeley DB 2.x, you must have version 2.3.4
+ or greater. If you want to use Berkeley DB 3.x or 4.x, any version
+ will do. For Berkeley DB 1.x, use either version 1.85 or 1.86.
+
+
+BUILDING THE MODULE
+-------------------
+
+Assuming you have met all the prerequisites, building the module should
+be relatively straightforward.
+
+Step 1 : If you are running either Solaris 2.5 or HP-UX 10 and want
+ to use Berkeley DB version 2, 3 or 4, read either the Solaris Notes
+ or HP-UX Notes sections below. If you are running Linux please
+ read the Linux Notes section before proceeding.
+
+Step 2 : Edit the file config.in to suit you local installation.
+ Instructions are given in the file.
+
+Step 3 : Build and test the module using this sequence of commands:
+
+ perl Makefile.PL
+ make
+ make test
+
+
+ NOTE:
+ If you have a very old version of Berkeley DB (i.e. pre 1.85),
+ three of the tests in the recno test harness may fail (tests 51,
+ 53 and 55). You can safely ignore the errors if you're never
+ going to use the broken functionality (recno databases with a
+ modified bval). Otherwise you'll have to upgrade your DB
+ library.
+
+
+INSTALLATION
+------------
+
+ make install
+
+UPDATES
+=======
+
+The most recent version of DB_File is always available at
+
+ http://www.cpan.org/modules/by-module/DB_File/
+
+TROUBLESHOOTING
+===============
+
+Here are some of the common problems people encounter when building
+DB_File.
+
+Missing db.h or libdb.a
+-----------------------
+
+If you get an error like this:
+
+ cc -c -I/usr/local/include -Dbool=char -DHAS_BOOL
+ -O2 -DVERSION=\"1.64\" -DXS_VERSION=\"1.64\" -fpic
+ -I/usr/local/lib/perl5/i586-linux/5.00404/CORE -DmDB_Prefix_t=size_t
+ -DmDB_Hash_t=u_int32_t DB_File.c
+ DB_File.xs:101: db.h: No such file or directory
+
+or this:
+
+ LD_RUN_PATH="/lib" cc -o blib/arch/auto/DB_File/DB_File.so -shared
+ -L/usr/local/lib DB_File.o -L/usr/local/lib -ldb
+ ld: cannot open -ldb: No such file or directory
+
+This symptom can imply:
+
+ 1. You don't have Berkeley DB installed on your system at all.
+ Solution: get & install Berkeley DB.
+
+ 2. You do have Berkeley DB installed, but it isn't in a standard place.
+ Solution: Edit config.in and set the LIB and INCLUDE variables to point
+ to the directories where libdb.a and db.h are installed.
+
+
+
+
+Undefined symbol db_version
+---------------------------
+
+DB_File seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /usr/bin/perl5.00404 -I./blib/arch -I./blib/lib
+ -I/usr/local/lib/perl5/i586-linux/5.00404 -I/usr/local/lib/perl5 -e 'use
+ Test::Harness qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t
+ t/db-btree..........Can't load './blib/arch/auto/DB_File/DB_File.so' for
+ module DB_File: ./blib/arch/auto/DB_File/DB_File.so: undefined symbol:
+ db_version at /usr/local/lib/perl5/i586-linux/5.00404/DynaLoader.pm
+ line 166.
+
+ at t/db-btree.t line 21
+ BEGIN failed--compilation aborted at t/db-btree.t line 21.
+ dubious Test returned status 2 (wstat 512, 0x200)
+
+This error usually happens when you have two version of Berkeley DB
+installed on your system -- specifically, if you have both version 1 and
+a newer version (i.e. version 2 or better) of Berkeley DB installed. If
+DB_File is built using the db.h for the newer Berkeley DB and the version
+1 Berkeley DB library you will trigger this error. Unfortunately the two
+versions aren't compatible with each other. The undefined symbol error is
+caused because Berkeley DB version 1 doesn't have the symbol db_version.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want DB_File to use.
+
+
+Undefined symbol dbopen
+-----------------------
+
+DB_File seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ ...
+ t/db-btree..........Can't load 'blib/arch/auto/DB_File/DB_File.so' for
+ module DB_File: blib/arch/auto/DB_File/DB_File.so: undefined symbol:
+ dbopen at /usr/local/lib/perl5/5.6.1/i586-linux/DynaLoader.pm line 206.
+ at t/db-btree.t line 23
+ Compilation failed in require at t/db-btree.t line 23.
+ ...
+
+This error usually happens when you have both version 1 and a more recent
+version of Berkeley DB installed on your system and DB_File attempts
+to build using the db.h for Berkeley DB version 1 and the newer version
+library. Unfortunately the two versions aren't compatible with each
+other. The undefined symbol error is actually caused because versions
+of Berkeley DB newer than version 1 doesn't have the symbol dbopen.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want DB_File to use.
+
+
+Incompatible versions of db.h and libdb
+---------------------------------------
+
+BerkeleyDB seems to have built correctly, but you get an error like this
+when you run the test harness:
+
+ $ make test
+ PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00560 -Iblib/arch
+ -Iblib/lib -I/home/paul/perl/install/5.005_60/lib/5.00560/i586-linux
+ -I/home/paul/perl/install/5.005_60/lib/5.00560 -e 'use Test::Harness
+ qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t
+ t/db-btree..........
+ DB_File was build with libdb version 2.3.7
+ but you are attempting to run it with libdb version 2.7.5
+ BEGIN failed--compilation aborted at t/db-btree.t line 21.
+ ...
+
+Another variation on the theme of having two versions of Berkeley DB on
+your system.
+
+Solution: Setting the LIB & INCLUDE variables in config.in to point to the
+ correct directories can sometimes be enough to fix this
+ problem. If that doesn't work the easiest way to fix the
+ problem is to either delete or temporarily rename the copies
+ of db.h and libdb.a that you don't want BerkeleyDB to use.
+ If you are running Linux, please read the Linux Notes section
+ below.
+
+
+Solaris build fails with "language optional software package not installed"
+---------------------------------------------------------------------------
+
+If you are trying to build this module under Solaris and you get an
+error message like this
+
+ /usr/ucb/cc: language optional software package not installed
+
+it means that Perl cannot find the C compiler on your system. The cryptic
+message is just Sun's way of telling you that you haven't bought their
+C compiler.
+
+When you build a Perl module that needs a C compiler, the Perl build
+system tries to use the same C compiler that was used to build perl
+itself. In this case your Perl binary was built with a C compiler that
+lived in /usr/ucb.
+
+To continue with building this module, you need to get a C compiler,
+or tell Perl where your C compiler is, if you already have one.
+
+Assuming you have now got a C compiler, what you do next will be dependant
+on what C compiler you have installed. If you have just installed Sun's
+C compiler, you shouldn't have to do anything. Just try rebuilding
+this module.
+
+If you have installed another C compiler, say gcc, you have to tell perl
+how to use it instead of /usr/ucb/cc.
+
+This set of options seems to work if you want to use gcc. Your mileage
+may vary.
+
+ perl Makefile.PL CC=gcc CCCDLFLAGS=-fPIC OPTIMIZE=" "
+ make test
+
+If that doesn't work for you, it's time to make changes to the Makefile
+by hand. Good luck!
+
+
+
+Solaris build fails with "gcc: unrecognized option `-KPIC'"
+-----------------------------------------------------------
+
+You are running Solaris and you get an error like this when you try to
+build this Perl module
+
+ gcc: unrecognized option `-KPIC'
+
+This symptom usually means that you are using a Perl binary that has been
+built with the Sun C compiler, but you are using gcc to build this module.
+
+When Perl builds modules that need a C compiler, it will attempt to use
+the same C compiler and command line options that was used to build perl
+itself. In this case "-KPIC" is a valid option for the Sun C compiler,
+but not for gcc. The equivalent option for gcc is "-fPIC".
+
+The solution is either:
+
+ 1. Build both Perl and this module with the same C compiler, either
+ by using the Sun C compiler for both or gcc for both.
+
+ 2. Try generating the Makefile for this module like this perl
+
+ perl Makefile.PL CC=gcc CCCDLFLAGS=-fPIC OPTIMIZE=" " LD=gcc
+ make test
+
+ This second option seems to work when mixing a Perl binary built
+ with the Sun C compiler and this module built with gcc. Your
+ mileage may vary.
+
+
+
+
+Linux Notes
+-----------
+
+Some older versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library
+that has version 2.x of Berkeley DB linked into it. This makes it
+difficult to build this module with anything other than the version of
+Berkeley DB that shipped with your Linux release. If you do try to use
+a different version of Berkeley DB you will most likely get the error
+described in the "Incompatible versions of db.h and libdb" section of
+this file.
+
+To make matters worse, prior to Perl 5.6.1, the perl binary itself
+*always* included the Berkeley DB library.
+
+If you want to use a newer version of Berkeley DB with this module, the
+easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x
+(or better).
+
+There are two approaches you can use to get older versions of Perl to
+work with specific versions of Berkeley DB. Both have their advantages
+and disadvantages.
+
+The first approach will only work when you want to build a version of
+Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use
+Berkeley DB 2.x, you must use the next approach. This approach involves
+rebuilding your existing version of Perl after applying an unofficial
+patch. The "patches" directory in the this module's source distribution
+contains a number of patch files. There is one patch file for every
+stable version of Perl since 5.004. Apply the appropriate patch to your
+Perl source tree before re-building and installing Perl from scratch.
+For example, assuming you are in the top-level source directory for
+Perl 5.6.0, the command below will apply the necessary patch. Remember
+to replace the path shown below with one that points to this module's
+patches directory.
+
+ patch -p1 -N </path/to/DB_File/patches/5.6.0
+
+Now rebuild & install perl. You should now have a perl binary that can
+be used to build this module. Follow the instructions in "BUILDING THE
+MODULE", remembering to set the INCLUDE and LIB variables in config.in.
+
+
+The second approach will work with both Berkeley DB 2.x and 3.x.
+Start by building Berkeley DB as a shared library. This is from
+the Berkeley DB build instructions:
+
+ Building Shared Libraries for the GNU GCC compiler
+
+ If you're using gcc and there's no better shared library example for
+ your architecture, the following shared library build procedure will
+ probably work.
+
+ Add the -fpic option to the CFLAGS value in the Makefile.
+
+ Rebuild all of your .o files. This will create a Berkeley DB library
+ that contains .o files with PIC code. To build the shared library,
+ then take the following steps in the library build directory:
+
+ % mkdir tmp
+ % cd tmp
+ % ar xv ../libdb.a
+ % gcc -shared -o libdb.so *.o
+ % mv libdb.so ..
+ % cd ..
+ % rm -rf tmp
+
+ Note, you may have to change the gcc line depending on the
+ requirements of your system.
+
+ The file libdb.so is your shared library
+
+Once you have built libdb.so, you will need to store it somewhere safe.
+
+ cp libdb.so /usr/local/BerkeleyDB/lib
+
+If you now set the LD_PRELOAD environment variable to point to this
+shared library, Perl will use it instead of the version of Berkeley DB
+that shipped with your Linux distribution.
+
+ export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so
+
+Finally follow the instructions in "BUILDING THE MODULE" to build,
+test and install this module. Don't forget to set the INCLUDE and LIB
+variables in config.in.
+
+Remember, you will need to have the LD_PRELOAD variable set anytime you
+want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD
+permanently set it will affect ALL commands you execute. This may be a
+problem if you run any commands that access a database created by the
+version of Berkeley DB that shipped with your Linux distribution.
+
+
+Solaris Notes
+-------------
+
+If you are running Solaris 2.5, and you get this error when you run the
+DB_File test harness:
+
+ libc internal error: _rmutex_unlock: rmutex not held.
+
+you probably need to install a Sun patch. It has been reported that
+Sun patch 103187-25 (or later revisions) fixes this problem.
+
+To find out if you have the patch installed, the command "showrev -p"
+will display the patches that are currently installed on your system.
+
+
+HP-UX 10 Notes
+--------------
+
+Some people running HP-UX 10 have reported getting an error like this
+when building DB_File with the native HP-UX compiler.
+
+ ld: (Warning) At least one PA 2.0 object file (DB_File.o) was detected.
+ The linked output may not run on a PA 1.x system.
+ ld: Invalid loader fixup for symbol "$000000A5".
+
+If this is the case for you, Berkeley DB needs to be recompiled with
+the +z or +Z option and the resulting library placed in a .sl file. The
+following steps should do the trick:
+
+ 1: Configure the Berkeley DB distribution with the +z or +Z C compiler
+ flag:
+
+ env "CFLAGS=+z" ../dist/configure ...
+
+ 2: Edit the Berkeley DB Makefile and change:
+
+ "libdb= libdb.a" to "libdb= libdb.sl".
+
+
+ 3: Build and install the Berkeley DB distribution as usual.
+
+HP-UX 11 Notes
+--------------
+
+Some people running the combination of HP-UX 11 and Berkeley DB 2.7.7 have
+reported getting this error when the run the test harness for DB_File
+
+ ...
+ lib/db-btree.........Can't call method "DELETE" on an undefined value at lib/db-btree.t line 216.
+ FAILED at test 26
+ lib/db-hash..........Can't call method "DELETE" on an undefined value at lib/db-hash.t line 183.
+ FAILED at test 22
+ ...
+
+The fix for this is to rebuild and install Berkeley DB with the bigfile
+option disabled.
+
+
+AIX NOTES
+---------
+
+I've had reports of a build failure like this on AIX 5.2 using the
+xlC compiler.
+
+ rm -f blib/arch/auto/DB_File/DB_File.so
+ LD_RUN_PATH="" ld -bhalt:4 -bM:SRE -bI:/usr/local/5.8.1/lib/perl5/5.8.1/aix/CORE/perl.exp -bE:DB_File.exp -bnoentry -lc
+ -L/usr/local/lib version.o DB_File.o -o blib/arch/auto/DB_File/DB_File.so
+ -L/usr/local/BerkeleyDB/lib -ldb -lpthread
+ ld: 0711-317 ERROR: Undefined symbol: .mutex_lock
+ ld: 0711-317 ERROR: Undefined symbol: .cond_signal
+ ld: 0711-317 ERROR: Undefined symbol: .mutex_unlock
+ ld: 0711-317 ERROR: Undefined symbol: .mutex_trylock
+ ld: 0711-317 ERROR: Undefined symbol: .cond_wait
+ ld: 0711-317 ERROR: Undefined symbol: .mutex_init
+ ld: 0711-317 ERROR: Undefined symbol: .cond_init
+ ld: 0711-317 ERROR: Undefined symbol: .mutex_destroy
+ ld: 0711-345 Use the -bloadmap or -bnoquiet option to obtain more information.
+ make: 1254-004 The error code from the last command is 8.
+
+Editing Makefile.PL, and changing the line
+
+ $LIBS .= " -lpthread" if $^O eq 'aix' ;
+
+to this
+
+ $LIBS .= " -lthread" if $^O eq 'aix' ;
+
+fixed the problem.
+
+
+FEEDBACK
+========
+
+General feedback/questions/bug reports can be sent to me at pmqs@cpan.org.
+
+Alternatively, if you have Usenet access, you can try the
+comp.databases.berkeley-db or comp.lang.perl.modules groups.
+
+
+
+How to report a problem with DB_File.
+-------------------------------------
+
+When reporting any problem, I need the information requested below.
+
+ 1. The *complete* output from running this
+
+ perl -V
+
+ Do not edit the output in any way.
+ Note, I want you to run "perl -V" and NOT "perl -v".
+
+ If your perl does not understand the "-V" option it is too
+ old. DB_File needs Perl version 5.00405 or better.
+
+ 2. The version of DB_File you have.
+ If you have successfully installed DB_File, this one-liner will
+ tell you:
+
+ perl -e 'use DB_File; print qq{DB_File ver $DB_File::VERSION\n}'
+
+ If you are running windows use this
+
+ perl -e "use DB_File; print qq{DB_File ver $DB_File::VERSION\n}"
+
+ If you haven't installed DB_File then search DB_File.pm for a line
+ like this:
+
+ $VERSION = "1.20" ;
+
+ 3. The version of Berkeley DB used to build DB_File and the version
+ that is used at runtime. (These are usually the same)
+
+ If you are using a version older than 1.85, think about upgrading. One
+ point to note if you are considering upgrading Berkeley DB - the
+ file formats for 1.85, 1.86, 2.0, 3.0 & 3.1 are all different.
+
+ If you have successfully installed DB_File, these commands will display
+ the versions I need
+
+ perl -MDB_File -e 'print qq{Built with Berkeley DB ver $DB_File::db_ver\n}'
+ perl -MDB_File -e 'print qq{Running with Berkeley DB ver $DB_File::db_version\n}'
+
+ If you are running windows use this
+
+ perl -e "use DB_File; print qq{Built with Berkeley DB ver $DB_File::db_ver\n}"
+ perl -e "use DB_File; print qq{Running Berkeley DB ver $DB_File::db_version\n}"
+
+ 4. A copy the file config.in from the DB_File main source directory.
+
+ 5. A listing of directories where Berkeley DB is installed.
+ For example, if Berkeley DB is installed in /usr/BerkeleDB/lib and
+ /usr/BerkeleyDB/include, I need the output from running this
+
+ ls -l /usr/BerkeleyDB/lib
+ ls -l /usr/BerkeleyDB/include
+
+ 6. If you are having problems building DB_File, send me a complete log
+ of what happened. Start by unpacking the DB_File module into a fresh
+ directory and keep a log of all the steps
+
+ [edit config.in, if necessary]
+ perl Makefile.PL
+ make
+ make test TEST_VERBOSE=1
+
+ 7. Now the difficult one. If you think you have found a bug in DB_File
+ and you want me to fix it, you will *greatly* enhance the chances
+ of me being able to track it down by sending me a small
+ self-contained Perl script that illustrates the problem you are
+ encountering. Include a summary of what you think the problem is
+ and a log of what happens when you run the script, in case I can't
+ reproduce your problem on my system. If possible, don't have the
+ script dependent on an existing 20Meg database. If the script you
+ send me can create the database itself then that is preferred.
+
+ I realise that in some cases this is easier said than done, so if
+ you can only reproduce the problem in your existing script, then
+ you can post me that if you want. Just don't expect me to find your
+ problem in a hurry, or at all. :-)
+
+
+CHANGES
+-------
+
+See the Changes file.
+
+Paul Marquess <pmqs@cpan.org>
diff --git a/lang/perl/DB_File/config.in b/lang/perl/DB_File/config.in
new file mode 100644
index 00000000..292b09a5
--- /dev/null
+++ b/lang/perl/DB_File/config.in
@@ -0,0 +1,97 @@
+# Filename: config.in
+#
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# last modified 9th Sept 1997
+# version 1.55
+
+# 1. Where is the file db.h?
+#
+# Change the path below to point to the directory where db.h is
+# installed on your system.
+
+INCLUDE = /usr/local/BerkeleyDB/include
+#INCLUDE = /usr/local/include
+#INCLUDE = /usr/include
+
+# 2. Where is libdb?
+#
+# Change the path below to point to the directory where libdb is
+# installed on your system.
+
+LIB = /usr/local/BerkeleyDB/lib
+#LIB = /usr/local/lib
+#LIB = /usr/lib
+
+# 3. What version of Berkely DB have you got?
+#
+# If you have version 2.0 or greater, you can skip this question.
+#
+# If you have Berkeley DB 1.78 or greater you shouldn't have to
+# change the definitions for PREFIX and HASH below.
+#
+# For older versions of Berkeley DB change both PREFIX and HASH to int.
+# Version 1.71, 1.72 and 1.73 are known to need this change.
+#
+# If you don't know what version you have have a look in the file db.h.
+#
+# Search for the string "DB_VERSION_MAJOR". If it is present, you
+# have Berkeley DB version 2 (or greater).
+#
+# If that didn't work, find the definition of the BTREEINFO typedef.
+# Check the return type from the prefix element. It should look like
+# this in an older copy of db.h:
+#
+# int (*prefix) __P((const DBT *, const DBT *));
+#
+# and like this in a more recent copy:
+#
+# size_t (*prefix) /* prefix function */
+# __P((const DBT *, const DBT *));
+#
+# Change the definition of PREFIX, below, to reflect the return type
+# of the prefix function in your db.h.
+#
+# Now find the definition of the HASHINFO typedef. Check the return
+# type of the hash element. Older versions look like this:
+#
+# int (*hash) __P((const void *, size_t));
+#
+# newer like this:
+#
+# u_int32_t /* hash function */
+# (*hash) __P((const void *, size_t));
+#
+# Change the definition of HASH, below, to reflect the return type of
+# the hash function in your db.h.
+#
+
+PREFIX = size_t
+HASH = u_int32_t
+
+# 4. Is the library called libdb?
+#
+# If you have copies of both 1.x and 2.x Berkeley DB installed on
+# your system it can sometimes be tricky to make sure you are using
+# the correct one. Renaming one (or creating a symbolic link) to
+# include the version number of the library can help.
+#
+# For example, if you have both Berkeley DB 2.3.12 and 1.85 on your
+# system and you want to use the Berkeley DB version 2 library you
+# could rename the version 2 library from libdb.a to libdb-2.3.12.a and
+# change the DBNAME line below to look like this:
+#
+# DBNAME = -ldb-2.3.12
+#
+# That will ensure you are linking the correct version of the DB
+# library.
+#
+# Note: If you are building this module with Win32, -llibdb will be
+# used by default.
+#
+# If you have changed the name of the library, uncomment the line
+# below (by removing the leading #) and edit the line to use the name
+# you have picked.
+
+#DBNAME = -ldb-2.4.10
+
+# end of file config.in
diff --git a/lang/perl/DB_File/dbinfo b/lang/perl/DB_File/dbinfo
new file mode 100644
index 00000000..b8cd65a9
--- /dev/null
+++ b/lang/perl/DB_File/dbinfo
@@ -0,0 +1,133 @@
+#!/usr/local/bin/perl
+
+# Name: dbinfo -- identify berkeley DB version used to create
+# a database file
+#
+# Author: Paul Marquess <Paul.Marquess@btinternet.com>
+# Version: 1.06
+# Date 27th March 2008
+#
+# Copyright (c) 1998-2008 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 => # DB_BTREEMAGIC
+ {
+ Type => "Btree",
+ Versions => # DB_BTREEVERSION
+ {
+ 1 => [0, "Unknown (older than 1.71)"],
+ 2 => [0, "Unknown (older than 1.71)"],
+ 3 => [0, "1.71 -> 1.85, 1.86"],
+ 4 => [0, "Unknown"],
+ 5 => [0, "2.0.0 -> 2.3.0"],
+ 6 => [0, "2.3.1 -> 2.7.7"],
+ 7 => [0, "3.0.x"],
+ 8 => [0, "3.1.x -> 4.0.x"],
+ 9 => [1, "4.1.x or greater"],
+ }
+ },
+ 0x061561 => # DB_HASHMAGIC
+ {
+ Type => "Hash",
+ Versions => # DB_HASHVERSION
+ {
+ 1 => [0, "Unknown (older than 1.71)"],
+ 2 => [0, "1.71 -> 1.85"],
+ 3 => [0, "1.86"],
+ 4 => [0, "2.0.0 -> 2.1.0"],
+ 5 => [0, "2.2.6 -> 2.7.7"],
+ 6 => [0, "3.0.x"],
+ 7 => [0, "3.1.x -> 4.0.x"],
+ 8 => [1, "4.1.x or greater"],
+ 9 => [1, "4.6.x or greater"],
+ }
+ },
+ 0x042253 => # DB_QAMMAGIC
+ {
+ Type => "Queue",
+ Versions => # DB_QAMVERSION
+ {
+ 1 => [0, "3.0.x"],
+ 2 => [0, "3.1.x"],
+ 3 => [0, "3.2.x -> 4.0.x"],
+ 4 => [1, "4.1.x 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, 30 ;
+
+
+my (@info) = unpack("NNNNNNC", $buff) ;
+my (@info1) = unpack("VVVVVVC", $buff) ;
+my ($magic, $version, $endian, $encrypt) ;
+
+if ($Data{$info[0]}) # first try DB 1.x format, big endian
+{
+ $magic = $info[0] ;
+ $version = $info[1] ;
+ $endian = "Big Endian" ;
+ $encrypt = "Not Supported";
+}
+elsif ($Data{$info1[0]}) # first try DB 1.x format, little endian
+{
+ $magic = $info1[0] ;
+ $version = $info1[1] ;
+ $endian = "Little Endian" ;
+ $encrypt = "Not Supported";
+}
+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} ;
+$magic = sprintf "%06X", $magic ;
+
+my $ver_string = "Unknown" ;
+
+if ( defined $type->{Versions}{$version} )
+{
+ $ver_string = $type->{Versions}{$version}[1];
+ if ($type->{Versions}{$version}[0] )
+ { $encrypt = $info[6] ? "Enabled" : "Disabled" }
+ else
+ { $encrypt = "Not Supported" }
+}
+
+print <<EOM ;
+File Type: Berkeley DB $type->{Type} file.
+File Version ID: $version
+Built with Berkeley DB: $ver_string
+Byte Order: $endian
+Magic: $magic
+Encryption: $encrypt
+EOM
+
+close F ;
+
+exit ;
diff --git a/lang/perl/DB_File/fallback.h b/lang/perl/DB_File/fallback.h
new file mode 100644
index 00000000..0213308a
--- /dev/null
+++ b/lang/perl/DB_File/fallback.h
@@ -0,0 +1,455 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant_6 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_TXN R_LAST R_NEXT R_PREV */
+ /* Offset 2 gives the best switch position. */
+ switch (name[2]) {
+ case 'L':
+ if (memEQ(name, "R_LAST", 6)) {
+ /* ^ */
+#ifdef R_LAST
+ *iv_return = R_LAST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "R_NEXT", 6)) {
+ /* ^ */
+#ifdef R_NEXT
+ *iv_return = R_NEXT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "R_PREV", 6)) {
+ /* ^ */
+#ifdef R_PREV
+ *iv_return = R_PREV;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '_':
+ if (memEQ(name, "DB_TXN", 6)) {
+ /* ^ */
+#ifdef DB_TXN
+ *iv_return = DB_TXN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_7 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_LOCK R_FIRST R_NOKEY */
+ /* Offset 3 gives the best switch position. */
+ switch (name[3]) {
+ case 'I':
+ if (memEQ(name, "R_FIRST", 7)) {
+ /* ^ */
+#ifdef R_FIRST
+ *iv_return = R_FIRST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "DB_LOCK", 7)) {
+ /* ^ */
+#ifdef DB_LOCK
+ *iv_return = DB_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "R_NOKEY", 7)) {
+ /* ^ */
+#ifdef R_NOKEY
+ *iv_return = R_NOKEY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_8 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ DB_SHMEM R_CURSOR R_IAFTER */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'M':
+ if (memEQ(name, "DB_SHMEM", 8)) {
+ /* ^ */
+#ifdef DB_SHMEM
+ *iv_return = DB_SHMEM;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "R_CURSOR", 8)) {
+ /* ^ */
+#ifdef R_CURSOR
+ *iv_return = R_CURSOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "R_IAFTER", 8)) {
+ /* ^ */
+#ifdef R_IAFTER
+ *iv_return = R_IAFTER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_9 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ HASHMAGIC RET_ERROR R_IBEFORE */
+ /* Offset 7 gives the best switch position. */
+ switch (name[7]) {
+ case 'I':
+ if (memEQ(name, "HASHMAGIC", 9)) {
+ /* ^ */
+#ifdef HASHMAGIC
+ *iv_return = HASHMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "RET_ERROR", 9)) {
+ /* ^ */
+#ifdef RET_ERROR
+ *iv_return = RET_ERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "R_IBEFORE", 9)) {
+ /* ^ */
+#ifdef R_IBEFORE
+ *iv_return = R_IBEFORE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_10 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ BTREEMAGIC R_FIXEDLEN R_SNAPSHOT __R_UNUSED */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'E':
+ if (memEQ(name, "R_FIXEDLEN", 10)) {
+ /* ^ */
+#ifdef R_FIXEDLEN
+ *iv_return = R_FIXEDLEN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "BTREEMAGIC", 10)) {
+ /* ^ */
+#ifdef BTREEMAGIC
+ *iv_return = BTREEMAGIC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "__R_UNUSED", 10)) {
+ /* ^ */
+#ifdef __R_UNUSED
+ *iv_return = __R_UNUSED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "R_SNAPSHOT", 10)) {
+ /* ^ */
+#ifdef R_SNAPSHOT
+ *iv_return = R_SNAPSHOT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ HASHVERSION RET_SPECIAL RET_SUCCESS R_RECNOSYNC R_SETCURSOR */
+ /* Offset 10 gives the best switch position. */
+ switch (name[10]) {
+ case 'C':
+ if (memEQ(name, "R_RECNOSYNC", 11)) {
+ /* ^ */
+#ifdef R_RECNOSYNC
+ *iv_return = R_RECNOSYNC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "RET_SPECIAL", 11)) {
+ /* ^ */
+#ifdef RET_SPECIAL
+ *iv_return = RET_SPECIAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "HASHVERSION", 11)) {
+ /* ^ */
+#ifdef HASHVERSION
+ *iv_return = HASHVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "R_SETCURSOR", 11)) {
+ /* ^ */
+#ifdef R_SETCURSOR
+ *iv_return = R_SETCURSOR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "RET_SUCCESS", 11)) {
+ /* ^ */
+#ifdef RET_SUCCESS
+ *iv_return = RET_SUCCESS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!bleedperl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV)};
+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));
+
+print constant_types(); # macro defs
+foreach (C_constant ("DB_File", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("DB_File", $types);
+__END__
+ */
+
+ switch (len) {
+ case 5:
+ if (memEQ(name, "R_DUP", 5)) {
+#ifdef R_DUP
+ *iv_return = R_DUP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 6:
+ return constant_6 (aTHX_ name, iv_return);
+ break;
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ return constant_8 (aTHX_ name, iv_return);
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return);
+ break;
+ case 10:
+ return constant_10 (aTHX_ name, iv_return);
+ break;
+ case 11:
+ return constant_11 (aTHX_ name, iv_return);
+ break;
+ case 12:
+ if (memEQ(name, "BTREEVERSION", 12)) {
+#ifdef BTREEVERSION
+ *iv_return = BTREEVERSION;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 13:
+ if (memEQ(name, "R_NOOVERWRITE", 13)) {
+#ifdef R_NOOVERWRITE
+ *iv_return = R_NOOVERWRITE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 14:
+ if (memEQ(name, "MAX_REC_NUMBER", 14)) {
+#ifdef MAX_REC_NUMBER
+ *iv_return = MAX_REC_NUMBER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 15:
+ /* Names all of length 15. */
+ /* MAX_PAGE_NUMBER MAX_PAGE_OFFSET */
+ /* Offset 9 gives the best switch position. */
+ switch (name[9]) {
+ case 'N':
+ if (memEQ(name, "MAX_PAGE_NUMBER", 15)) {
+ /* ^ */
+#ifdef MAX_PAGE_NUMBER
+ *iv_return = MAX_PAGE_NUMBER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "MAX_PAGE_OFFSET", 15)) {
+ /* ^ */
+#ifdef MAX_PAGE_OFFSET
+ *iv_return = MAX_PAGE_OFFSET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
diff --git a/lang/perl/DB_File/fallback.xs b/lang/perl/DB_File/fallback.xs
new file mode 100644
index 00000000..8650cdf7
--- /dev/null
+++ b/lang/perl/DB_File/fallback.xs
@@ -0,0 +1,88 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid DB_File macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined DB_File macro %s, used", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing DB_File macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
diff --git a/lang/perl/DB_File/hints/dynixptx.pl b/lang/perl/DB_File/hints/dynixptx.pl
new file mode 100644
index 00000000..bb5ffa56
--- /dev/null
+++ b/lang/perl/DB_File/hints/dynixptx.pl
@@ -0,0 +1,3 @@
+# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug
+
+$self->{LIBS} = ['-lm -lc'];
diff --git a/lang/perl/DB_File/hints/sco.pl b/lang/perl/DB_File/hints/sco.pl
new file mode 100644
index 00000000..ff604409
--- /dev/null
+++ b/lang/perl/DB_File/hints/sco.pl
@@ -0,0 +1,2 @@
+# osr5 needs to explicitly link against libc to pull in some static symbols
+$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ;
diff --git a/lang/perl/DB_File/patches/5.004 b/lang/perl/DB_File/patches/5.004
new file mode 100644
index 00000000..0665d1f6
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004
@@ -0,0 +1,93 @@
+diff -rc perl5.004.orig/Configure perl5.004/Configure
+*** perl5.004.orig/Configure 1997-05-13 18:20:34.000000000 +0100
+--- perl5.004/Configure 2003-04-26 16:36:53.000000000 +0100
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9902,9907 ****
+--- 9903,9916 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10370,10375 ****
+--- 10379,10385 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004.orig/Makefile.SH perl5.004/Makefile.SH
+*** perl5.004.orig/Makefile.SH 1997-05-01 15:22:39.000000000 +0100
+--- perl5.004/Makefile.SH 2003-04-26 16:37:23.000000000 +0100
+***************
+*** 119,125 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 119,125 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004.orig/myconfig perl5.004/myconfig
+*** perl5.004.orig/myconfig 1996-12-21 01:13:20.000000000 +0000
+--- perl5.004/myconfig 2003-04-26 16:37:51.000000000 +0100
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004.orig/patchlevel.h perl5.004/patchlevel.h
+*** perl5.004.orig/patchlevel.h 1997-05-15 23:15:17.000000000 +0100
+--- perl5.004/patchlevel.h 2003-04-26 16:38:11.000000000 +0100
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.004_01 b/lang/perl/DB_File/patches/5.004_01
new file mode 100644
index 00000000..1b05eb4e
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004_01
@@ -0,0 +1,217 @@
+diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure
+*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997
+--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9907,9912 ****
+--- 9908,9921 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10375,10380 ****
+--- 10384,10390 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH
+*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997
+--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm
+*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997
+--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000
+***************
+*** 170,176 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 170,176 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm
+*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997
+--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $Verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $Verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $Verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $Verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997
+--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000
+***************
+*** 2137,2143 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2137,2143 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig
+*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h
+*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997
+--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.004_02 b/lang/perl/DB_File/patches/5.004_02
new file mode 100644
index 00000000..238f8737
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004_02
@@ -0,0 +1,217 @@
+diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure
+*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997
+--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9911,9916 ****
+--- 9912,9925 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10379,10384 ****
+--- 10388,10394 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH
+*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997
+--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm
+*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm
+*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997
+--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997
+--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000
+***************
+*** 2224,2230 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2224,2230 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig
+*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h
+*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997
+--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.004_03 b/lang/perl/DB_File/patches/5.004_03
new file mode 100644
index 00000000..06331eac
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004_03
@@ -0,0 +1,223 @@
+diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure
+*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997
+--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9911,9916 ****
+--- 9912,9925 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10379,10384 ****
+--- 10388,10394 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+Only in perl5.004_03: Configure.orig
+diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH
+*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997
+--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000
+***************
+*** 126,132 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 126,132 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+Only in perl5.004_03: Makefile.SH.orig
+diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm
+*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm
+*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997
+--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 186,196 ****
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 186,196 ----
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+! # (caller should probably use the list in $Config{perllibs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 540,546 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 540,546 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig
+Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej
+diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997
+--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000
+***************
+*** 2224,2230 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2224,2230 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig
+diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig
+*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996
+--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h
+*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997
+--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000
+***************
+*** 38,43 ****
+--- 38,44 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
+Only in perl5.004_03: patchlevel.h.orig
diff --git a/lang/perl/DB_File/patches/5.004_04 b/lang/perl/DB_File/patches/5.004_04
new file mode 100644
index 00000000..a227dc70
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004_04
@@ -0,0 +1,209 @@
+diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure
+*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997
+--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 9910,9915 ****
+--- 9911,9924 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10378,10383 ****
+--- 10387,10393 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH
+*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997
+--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000
+***************
+*** 129,135 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 129,135 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm
+*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm
+*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997
+--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 189,195 ****
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+--- 189,195 ----
+ return ("", "", "", "") unless $potential_libs;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my($libpth) = $Config{'libpth'};
+ my($libext) = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 539,545 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 539,545 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997
+--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000
+***************
+*** 2229,2235 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2229,2235 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig
+*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997
+--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000
+***************
+*** 35,41 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 35,41 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h
+*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997
+--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.004_05 b/lang/perl/DB_File/patches/5.004_05
new file mode 100644
index 00000000..51c8bf35
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.004_05
@@ -0,0 +1,209 @@
+diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure
+*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000
+--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000
+***************
+*** 188,193 ****
+--- 188,194 ----
+ mv=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 10164,10169 ****
+--- 10165,10178 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 10648,10653 ****
+--- 10657,10663 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH
+*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000
+--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000
+***************
+*** 151,157 ****
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 151,157 ----
+ ext = \$(dynamic_ext) \$(static_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm
+*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997
+--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000
+***************
+*** 178,184 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 178,184 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm
+*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000
+--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 590,596 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 590,596 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm
+*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000
+--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000
+***************
+*** 2246,2252 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2246,2252 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig
+*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000
+--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so
+ useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h
+*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000
+--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.005 b/lang/perl/DB_File/patches/5.005
new file mode 100644
index 00000000..effee3e8
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.005
@@ -0,0 +1,209 @@
+diff -rc perl5.005.orig/Configure perl5.005/Configure
+*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998
+--- perl5.005/Configure Sun Nov 12 21:30:40 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11279,11284 ****
+--- 11280,11293 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11804,11809 ****
+--- 11813,11819 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH
+*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm
+*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm
+*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998
+--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 290,296 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 290,296 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 598,604 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 598,604 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm
+*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.005.orig/myconfig perl5.005/myconfig
+*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005/myconfig Sun Nov 12 21:30:41 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h
+*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998
+--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.005_01 b/lang/perl/DB_File/patches/5.005_01
new file mode 100644
index 00000000..2a05dd54
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.005_01
@@ -0,0 +1,209 @@
+diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure
+*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998
+--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11279,11284 ****
+--- 11280,11293 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11804,11809 ****
+--- 11813,11819 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH
+*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm
+*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm
+*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998
+--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 290,296 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 290,296 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 598,604 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 598,604 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig
+*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h
+*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000
+--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000
+***************
+*** 39,44 ****
+--- 39,45 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.005_02 b/lang/perl/DB_File/patches/5.005_02
new file mode 100644
index 00000000..5dd57ddc
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.005_02
@@ -0,0 +1,264 @@
+diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure
+*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000
+--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000
+***************
+*** 234,239 ****
+--- 234,240 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11334,11339 ****
+--- 11335,11348 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 11859,11864 ****
+--- 11868,11874 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+Only in perl5.005_02: Configure.orig
+diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH
+*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998
+--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000
+***************
+*** 150,156 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 150,156 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+Only in perl5.005_02: Makefile.SH.orig
+diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm
+*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998
+--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm
+*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000
+--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 333,339 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 333,339 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 623,629 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+--- 623,629 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>
+ as well as in C<$Config{libpth}>. For each library that is found, a
+***************
+*** 666,672 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 666,672 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 676,682 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 676,682 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig
+diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998
+--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000
+***************
+*** 2281,2287 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2281,2287 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig
+diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig
+*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998
+--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000
+***************
+*** 34,40 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 34,40 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h
+*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000
+--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000
+***************
+*** 40,45 ****
+--- 40,46 ----
+ */
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/patches/5.005_03 b/lang/perl/DB_File/patches/5.005_03
new file mode 100644
index 00000000..115f9f5b
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.005_03
@@ -0,0 +1,250 @@
+diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure
+*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999
+--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000
+***************
+*** 208,213 ****
+--- 208,214 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 11642,11647 ****
+--- 11643,11656 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 12183,12188 ****
+--- 12192,12198 ----
+ patchlevel='$patchlevel'
+ path_sep='$path_sep'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH
+*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999
+--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000
+***************
+*** 58,67 ****
+ shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
+ case "$osvers" in
+ 3*)
+! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib"
+ ;;
+ *)
+! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib"
+ ;;
+ esac
+ aixinstdir=`pwd | sed 's/\/UU$//'`
+--- 58,67 ----
+ shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
+ case "$osvers" in
+ 3*)
+! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib"
+ ;;
+ *)
+! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib"
+ ;;
+ esac
+ aixinstdir=`pwd | sed 's/\/UU$//'`
+***************
+*** 155,161 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 155,161 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm
+*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999
+--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000
+***************
+*** 194,200 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 194,200 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm
+*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999
+--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000
+***************
+*** 16,33 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 16,33 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 196,202 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 196,202 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 336,342 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 336,342 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 626,632 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+--- 626,632 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+***************
+*** 670,676 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 670,676 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 680,686 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 680,686 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm
+*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999
+--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000
+***************
+*** 2284,2290 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2284,2290 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
diff --git a/lang/perl/DB_File/patches/5.6.0 b/lang/perl/DB_File/patches/5.6.0
new file mode 100644
index 00000000..1f9b3b62
--- /dev/null
+++ b/lang/perl/DB_File/patches/5.6.0
@@ -0,0 +1,294 @@
+diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure
+*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000
+--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000
+***************
+*** 217,222 ****
+--- 217,223 ----
+ nm=''
+ nroff=''
+ perl=''
++ perllibs=''
+ pg=''
+ pmake=''
+ pr=''
+***************
+*** 14971,14976 ****
+--- 14972,14985 ----
+ shift
+ extensions="$*"
+
++ : Remove libraries needed only for extensions
++ : The appropriate ext/Foo/Makefile.PL will add them back in, if
++ : necessary.
++ set X `echo " $libs " |
++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'`
++ shift
++ perllibs="$*"
++
+ : Remove build directory name from cppstdin so it can be used from
+ : either the present location or the final installed location.
+ echo " "
+***************
+*** 15640,15645 ****
+--- 15649,15655 ----
+ path_sep='$path_sep'
+ perl5='$perl5'
+ perl='$perl'
++ perllibs='$perllibs'
+ perladmin='$perladmin'
+ perlpath='$perlpath'
+ pg='$pg'
+diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH
+*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000
+--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000
+***************
+*** 70,76 ****
+ *) shrpldflags="$shrpldflags -b noentry"
+ ;;
+ esac
+! shrpldflags="$shrpldflags $ldflags $libs $cryptlib"
+ linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl"
+ ;;
+ hpux*)
+--- 70,76 ----
+ *) shrpldflags="$shrpldflags -b noentry"
+ ;;
+ esac
+! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib"
+ linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl"
+ ;;
+ hpux*)
+***************
+*** 176,182 ****
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $libs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+--- 176,182 ----
+ ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+ DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+! libs = $perllibs $cryptlib
+
+ public = perl $suidperl utilities translators
+
+***************
+*** 333,339 ****
+ case "$osname" in
+ aix)
+ $spitshell >>Makefile <<!GROK!THIS!
+! LIBS = $libs
+ # In AIX we need to change this for building Perl itself from
+ # its earlier definition (which is for building external
+ # extensions *after* Perl has been built and installed)
+--- 333,339 ----
+ case "$osname" in
+ aix)
+ $spitshell >>Makefile <<!GROK!THIS!
+! LIBS = $perllibs
+ # In AIX we need to change this for building Perl itself from
+ # its earlier definition (which is for building external
+ # extensions *after* Perl has been built and installed)
+diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm
+*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000
+--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000
+***************
+*** 193,199 ****
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+--- 193,199 ----
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+! push(@potential_libs, $Config{perllibs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm
+*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000
+--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000
+***************
+*** 17,34 ****
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+--- 17,34 ----
+
+ sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+! if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+! $potential_libs .= $Config{perllibs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+! my($libs) = $Config{'perllibs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+***************
+*** 198,204 ****
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+--- 198,204 ----
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+! my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+***************
+*** 338,344 ****
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+--- 338,344 ----
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+***************
+*** 624,630 ****
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+--- 624,630 ----
+ =item *
+
+ If C<$potential_libs> is empty, the return value will be empty.
+! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
+ will be appended to the list of C<$potential_libs>. The libraries
+ will be searched for in the directories specified in C<$potential_libs>,
+ C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+***************
+*** 668,674 ****
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+--- 668,674 ----
+ alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+ An entry that matches C</:nodefault/i> disables the appending of default
+! libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
+
+ An entry that matches C</:nosearch/i> disables all searching for
+ the libraries specified after it. Translation of C<-Lfoo> and
+***************
+*** 678,684 ****
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{libs}>.
+
+ =item *
+
+--- 678,684 ----
+
+ An entry that matches C</:search/i> reenables searching for
+ the libraries specified after it. You can put it at the end to
+! enable searching for default libraries specified by C<$Config{perllibs}>.
+
+ =item *
+
+diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm
+*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000
+--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000
+***************
+*** 2450,2456 ****
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+--- 2450,2456 ----
+ MAP_STATIC = ",
+ join(" \\\n\t", reverse sort keys %static), "
+
+! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+ ";
+
+ if (defined $libperl) {
+diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH
+*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000
+--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000
+***************
+*** 48,54 ****
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+--- 48,54 ----
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+! libs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h
+*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000
+--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000
+***************
+*** 70,75 ****
+--- 70,76 ----
+ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
+ static char *local_patches[] = {
+ NULL
++ ,"NODB-1.0 - remove -ldb from core perl binary."
+ ,NULL
+ };
+
diff --git a/lang/perl/DB_File/ppport.h b/lang/perl/DB_File/ppport.h
new file mode 100644
index 00000000..effa5072
--- /dev/null
+++ b/lang/perl/DB_File/ppport.h
@@ -0,0 +1,364 @@
+/* This file is Based on output from
+ * Perl/Pollution/Portability Version 2.0000 */
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(d) (IV)(d)
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(d)
+#endif
+
+#ifndef dTHR
+# ifdef WIN32
+# define dTHR extern int Perl___notused
+# else
+# define dTHR extern int errno
+# endif
+#endif
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if PERL_REVISION == 5 && \
+ (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+# define PERL_UNUSED_DECL __attribute__((unused))
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+#ifdef SvPVbyte
+# if PERL_REVISION == 5 && PERL_VERSION < 7
+ /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
+# undef SvPVbyte
+# define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
+ static char *
+ my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+ {
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+ }
+# endif
+#else
+# define SvPVbyte SvPV
+#endif
+
+#ifndef SvUTF8_off
+# define SvUTF8_off(s)
+#endif
+
+#if 1
+#ifdef DBM_setFilter
+#undef DBM_setFilter
+#undef DBM_ckFilter
+#endif
+#endif
+
+#ifndef DBM_setFilter
+
+/*
+ The DBM_setFilter & DBM_ckFilter macros are only used by
+ the *DB*_File modules
+*/
+
+#define DBM_setFilter(db_type,code) \
+ { \
+ if (db_type) \
+ RETVAL = sv_mortalcopy(db_type) ; \
+ ST(0) = RETVAL ; \
+ if (db_type && (code == &PL_sv_undef)) { \
+ SvREFCNT_dec(db_type) ; \
+ db_type = NULL ; \
+ } \
+ else if (code) { \
+ if (db_type) \
+ sv_setsv(db_type, code) ; \
+ else \
+ db_type = newSVsv(code) ; \
+ } \
+ }
+
+#define DBM_ckFilter(arg,type,name) \
+ if (db->type) { \
+ /*printf("ckFilter %s\n", name);*/ \
+ if (db->filtering) { \
+ croak("recursion detected in %s", name) ; \
+ } \
+ ENTER ; \
+ SAVETMPS ; \
+ SAVEINT(db->filtering) ; \
+ db->filtering = TRUE ; \
+ SAVESPTR(DEFSV) ; \
+ if (name[7] == 's') \
+ arg = newSVsv(arg); \
+ DEFSV = arg ; \
+ SvTEMP_off(arg) ; \
+ PUSHMARK(SP) ; \
+ PUTBACK ; \
+ (void) perl_call_sv(db->type, G_DISCARD); \
+ SPAGAIN ; \
+ PUTBACK ; \
+ FREETMPS ; \
+ LEAVE ; \
+ if (name[7] == 's'){ \
+ arg = sv_2mortal(arg); \
+ } \
+ SvOKp(arg); \
+ }
+
+#endif /* DBM_setFilter */
+
+#endif /* _P_P_PORTABILITY_H_ */
diff --git a/lang/perl/DB_File/t/db-btree.t b/lang/perl/DB_File/t/db-btree.t
new file mode 100644
index 00000000..29c70a17
--- /dev/null
+++ b/lang/perl/DB_File/t/db-btree.t
@@ -0,0 +1,1657 @@
+#!./perl -w
+
+use warnings;
+use strict;
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+}
+
+BEGIN
+{
+ if ($^O eq 'darwin'
+ && (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7
+ && $Config{db_version_major} == 1
+ && $Config{db_version_minor} == 0
+ && $Config{db_version_patch} == 0) {
+ warn <<EOM;
+#
+# This test is known to crash in Mac OS X versions 10.2 (or earlier)
+# because of the buggy Berkeley DB version included with the OS.
+#
+EOM
+ }
+}
+
+use DB_File;
+use Fcntl;
+
+print "1..197\n";
+
+unlink glob "__db.*";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+sub lexical
+{
+ my(@a) = unpack ("C*", $a) ;
+ my(@b) = unpack ("C*", $b) ;
+
+ my $len = (@a > @b ? @b : @a) ;
+ my $i = 0 ;
+
+ foreach $i ( 0 .. $len -1) {
+ return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+ }
+
+ return @a - @b ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ $result = normalise($result) ;
+ return $result ;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ my $result = docat($file);
+ unlink $file ;
+ return $result ;
+}
+
+sub normalise
+{
+ my $data = shift ;
+ $data =~ s#\r\n#\n#g
+ if $^O eq 'cygwin' ;
+
+ return $data ;
+}
+
+sub safeUntie
+{
+ my $hashref = shift ;
+ my $no_inner = 1;
+ local $SIG{__WARN__} = sub {-- $no_inner } ;
+ untie %$hashref;
+ return $no_inner;
+}
+
+
+
+my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+my $Dfile = "dbbtree.tmp";
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to BTREEINFO
+
+my $dbh = new DB_File::BTREEINFO ;
+ok(1, ! defined $dbh->{flags}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{lorder}) ;
+ok(5, ! defined $dbh->{minkeypage}) ;
+ok(6, ! defined $dbh->{maxkeypage}) ;
+ok(7, ! defined $dbh->{compare}) ;
+ok(8, ! defined $dbh->{prefix}) ;
+
+$dbh->{flags} = 3000 ;
+ok(9, $dbh->{flags} == 3000) ;
+
+$dbh->{cachesize} = 9000 ;
+ok(10, $dbh->{cachesize} == 9000);
+
+$dbh->{psize} = 400 ;
+ok(11, $dbh->{psize} == 400) ;
+
+$dbh->{lorder} = 65 ;
+ok(12, $dbh->{lorder} == 65) ;
+
+$dbh->{minkeypage} = 123 ;
+ok(13, $dbh->{minkeypage} == 123) ;
+
+$dbh->{maxkeypage} = 1234 ;
+ok(14, $dbh->{maxkeypage} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
+
+# Now check the interface to BTREE
+
+my ($X, %h) ;
+ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+die "Could not tie: $!" unless $X;
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
+ || $noMode{$^O} );
+
+my ($key, $value, $i);
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(19, !$i ) ;
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(20, $h{'abc'} eq 'ABC' );
+ok(21, ! defined $h{'jimmy'} ) ;
+ok(22, ! exists $h{'jimmy'} ) ;
+ok(23, defined $h{'abc'} ) ;
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+# tie to the same file again
+ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+my @keys = keys(%h);
+my @values = values(%h);
+
+ok(25, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+ok(26, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(27, $#keys == 31) ;
+
+#Check that the keys can be retrieved in order
+my @b = keys %h ;
+my @c = sort lexical @b ;
+ok(28, ArrayCompare(\@b, \@c)) ;
+
+$h{'foo'} = '';
+ok(29, $h{'foo'} eq '' ) ;
+
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+ $h{''} = 'bar';
+ $result = ( $h{''} eq 'bar' );
+}
+else
+ { $result = 1 }
+ok(30, $result) ;
+
+# check cache overflow and numeric keys and contents
+my $ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(31, $ok);
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(32, $size > 0 );
+
+@h{0..200} = 200..400;
+my @foo = @h{0..200};
+ok(33, join(':',200..400) eq join(':',@foo) );
+
+# Now check all the non-tie specific stuff
+
+
+# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
+# an existing record.
+
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(34, $status == 1 );
+
+# check that the value of the key 'x' has not been changed by the
+# previous test
+ok(35, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(36, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(37, $status == 0 );
+ok(38, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(39, $status == 0 );
+if ($null_keys_allowed) {
+ $status = $X->del('') ;
+} else {
+ $status = 0 ;
+}
+ok(40, $status == 0 );
+
+# Make sure that the key deleted, cannot be retrieved
+ok(41, ! defined $h{'q'}) ;
+ok(42, ! defined $h{''}) ;
+
+undef $X ;
+untie %h ;
+
+ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
+
+# Attempting to delete a non-existent key should fail
+
+$status = $X->del('joe') ;
+ok(44, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(45, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(46, $status == 0 );
+ok(47, $value eq 'A' );
+
+# seq
+# ###
+
+# use seq to find an approximate match
+$key = 'ke' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(48, $status == 0 );
+ok(49, $key eq 'key' );
+ok(50, $value eq 'value' );
+
+# seq when the key does not match
+$key = 'zzz' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(51, $status == 1 );
+
+
+# use seq to set the cursor, then delete the record @ the cursor.
+
+$key = 'x' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(52, $status == 0 );
+ok(53, $key eq 'x' );
+ok(54, $value eq 'X' );
+$status = $X->del(0, R_CURSOR) ;
+ok(55, $status == 0 );
+$status = $X->get('x', $value) ;
+ok(56, $status == 1 );
+
+# ditto, but use put to replace the key/value pair.
+$key = 'y' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(57, $status == 0 );
+ok(58, $key eq 'y' );
+ok(59, $value eq 'Y' );
+
+$key = "replace key" ;
+$value = "replace value" ;
+$status = $X->put($key, $value, R_CURSOR) ;
+ok(60, $status == 0 );
+ok(61, $key eq 'replace key' );
+ok(62, $value eq 'replace value' );
+$status = $X->get('y', $value) ;
+ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1)
+ # only worked because of a bug in 1.85/6
+
+# use seq to walk forwards through a file
+
+$status = $X->seq($key, $value, R_FIRST) ;
+ok(64, $status == 0 );
+my $previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_NEXT)) == 0)
+{
+ ($ok = 0), last if ($previous cmp $key) == 1 ;
+}
+
+ok(65, $status == 1 );
+ok(66, $ok == 1 );
+
+# use seq to walk backwards through a file
+$status = $X->seq($key, $value, R_LAST) ;
+ok(67, $status == 0 );
+$previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_PREV)) == 0)
+{
+ ($ok = 0), last if ($previous cmp $key) == -1 ;
+ #print "key = [$key] value = [$value]\n" ;
+}
+
+ok(68, $status == 1 );
+ok(69, $ok == 1 );
+
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(70, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(71, 1 );
+#ok(71, $status != 0 );
+
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# Now try an in memory file
+my $Y;
+ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+# fd with an in memory file should return failure
+$status = $Y->fd ;
+ok(73, $status == -1 );
+
+
+undef $Y ;
+untie %h ;
+
+# Duplicate keys
+my $bt = new DB_File::BTREEINFO ;
+$bt->{flags} = R_DUP ;
+my ($YY, %hh);
+ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
+
+$hh{'Wall'} = 'Larry' ;
+$hh{'Wall'} = 'Stone' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
+$hh{'Smith'} = 'John' ;
+$hh{'mouse'} = 'mickey' ;
+
+# first work in scalar context
+ok(75, scalar $YY->get_dup('Unknown') == 0 );
+ok(76, scalar $YY->get_dup('Smith') == 1 );
+ok(77, scalar $YY->get_dup('Wall') == 4 );
+
+# now in list context
+my @unknown = $YY->get_dup('Unknown') ;
+ok(78, "@unknown" eq "" );
+
+my @smith = $YY->get_dup('Smith') ;
+ok(79, "@smith" eq "John" );
+
+{
+my @wall = $YY->get_dup('Wall') ;
+my %wall ;
+@wall{@wall} = @wall ;
+ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
+}
+
+# hash
+my %unknown = $YY->get_dup('Unknown', 1) ;
+ok(81, keys %unknown == 0 );
+
+my %smith = $YY->get_dup('Smith', 1) ;
+ok(82, keys %smith == 1 && $smith{'John'}) ;
+
+my %wall = $YY->get_dup('Wall', 1) ;
+ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 2);
+
+undef $YY ;
+untie %hh ;
+unlink $Dfile;
+
+
+# test multiple callbacks
+my $Dfile1 = "btree1" ;
+my $Dfile2 = "btree2" ;
+my $Dfile3 = "btree3" ;
+
+my $dbh1 = new DB_File::BTREEINFO ;
+$dbh1->{compare} = sub {
+ no warnings 'numeric' ;
+ $_[0] <=> $_[1] } ;
+
+my $dbh2 = new DB_File::BTREEINFO ;
+$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
+
+my $dbh3 = new DB_File::BTREEINFO ;
+$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
+
+
+my (%g, %k);
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!;
+tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!;
+tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!;
+
+my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
+my (@srt_1, @srt_2, @srt_3);
+{
+ no warnings 'numeric' ;
+ @srt_1 = sort { $a <=> $b } @Keys ;
+}
+@srt_2 = sort { $a cmp $b } @Keys ;
+@srt_3 = sort { length $a <=> length $b } @Keys ;
+
+foreach (@Keys) {
+ $h{$_} = 1 ;
+ $g{$_} = 1 ;
+ $k{$_} = 1 ;
+}
+
+sub ArrayCompare
+{
+ my($a, $b) = @_ ;
+
+ return 0 if @$a != @$b ;
+
+ foreach (1 .. length @$a)
+ {
+ return 0 unless $$a[$_] eq $$b[$_] ;
+ }
+
+ 1 ;
+}
+
+ok(84, ArrayCompare (\@srt_1, [keys %h]) );
+ok(85, ArrayCompare (\@srt_2, [keys %g]) );
+ok(86, ArrayCompare (\@srt_3, [keys %k]) );
+
+untie %h ;
+untie %g ;
+untie %k ;
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+# clear
+# #####
+
+ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(88, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(89, $i == 0);
+
+untie %h ;
+unlink $Dfile1 ;
+
+{
+ # check that attempting to tie an array to a DB_BTREE will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
+ ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ our (@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(91, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+ ' ;
+
+ main::ok(92, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(93, $@ eq "") ;
+ main::ok(94, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(95, $@ eq "") ;
+ main::ok(96, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(97, $@ eq "" ) ;
+ main::ok(98, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(99, $@ eq "") ;
+ main::ok(100, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+{
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(102, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(103, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(104, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(105, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(106, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(107, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(108, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(109, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(110, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(111, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(112, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(113, $h{"fred"} eq "joe");
+ ok(114, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(115, $db->FIRSTKEY() eq "fred") ;
+ ok(116, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(117, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(118, $h{"fred"} eq "joe");
+ ok(119, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(120, $db->FIRSTKEY() eq "fred") ;
+ ok(121, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(123, $result{"store key"} eq "store key - 1: [fred]");
+ ok(124, $result{"store value"} eq "store value - 1: [joe]");
+ ok(125, ! defined $result{"fetch key"} );
+ ok(126, ! defined $result{"fetch value"} );
+ ok(127, $_ eq "original") ;
+
+ ok(128, $db->FIRSTKEY() eq "fred") ;
+ ok(129, $result{"store key"} eq "store key - 1: [fred]");
+ ok(130, $result{"store value"} eq "store value - 1: [joe]");
+ ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(132, ! defined $result{"fetch value"} );
+ ok(133, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(134, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(135, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(137, ! defined $result{"fetch value"} );
+ ok(138, $_ eq "original") ;
+
+ ok(139, $h{"fred"} eq "joe");
+ ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(141, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(144, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+
+{
+ # Examples from the POD
+
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 1
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # specify the Perl sub that will do the comparison
+ $DB_BTREE->{'compare'} = \&Compare ;
+
+ unlink "tree" ;
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open file 'tree': $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+ unlink "tree" ;
+ }
+
+ delete $DB_BTREE->{'compare'} ;
+
+ ok(147, docat_del($file) eq <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 2
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, %h);
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the associative array
+ # and print each key/value pair.
+ foreach (keys %h)
+ { print "$_ -> $h{$_}\n" }
+
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
+EOM
+Smith -> John
+Wall -> Larry
+Wall -> Larry
+Wall -> Larry
+mouse -> mickey
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 3
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $status, $key, $value);
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # 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) )
+ { print "$key -> $value\n" }
+
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Larry
+mouse -> mickey
+EOM
+Smith -> John
+Wall -> Larry
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
+EOM
+
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 4
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h);
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ my $cnt = $x->get_dup("Wall") ;
+ print "Wall occurred $cnt times\n" ;
+
+ my %hash = $x->get_dup("Wall", 1) ;
+ print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
+
+ my @list = sort $x->get_dup("Wall") ;
+ print "Wall => [@list]\n" ;
+
+ @list = $x->get_dup("Smith") ;
+ print "Smith => [@list]\n" ;
+
+ @list = $x->get_dup("Dog") ;
+ print "Dog => [@list]\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(150, docat_del($file) eq <<'EOM') ;
+Wall occurred 3 times
+Larry is there
+There are 2 Brick Walls
+Wall => [Brick Brick Larry]
+Smith => [John]
+Dog => []
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 5
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $found);
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ print "Harry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(151, docat_del($file) eq <<'EOM') ;
+Larry Wall is there
+Harry Wall is not there
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 6
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+
+ my ($filename, $x, %h, $found);
+
+ $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $x->del_dup("Wall", "Larry") ;
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(152, docat_del($file) eq <<'EOM') ;
+Larry Wall is not there
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 7
+ ###
+
+ use warnings FATAL => qw(all) ;
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ my ($filename, $x, %h, $st, $key, $value);
+
+ sub match
+ {
+ my $key = shift ;
+ my $value = 0;
+ my $orig_key = $key ;
+ $x->seq($key, $value, R_CURSOR) ;
+ print "$orig_key\t-> $key\t-> $value\n" ;
+ }
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'mouse'} = 'mickey' ;
+ $h{'Wall'} = 'Larry' ;
+ $h{'Walls'} = 'Brick' ;
+ $h{'Smith'} = 'John' ;
+
+
+ $key = $value = 0 ;
+ print "IN ORDER\n" ;
+ for ($st = $x->seq($key, $value, R_FIRST) ;
+ $st == 0 ;
+ $st = $x->seq($key, $value, R_NEXT) )
+
+ { print "$key -> $value\n" }
+
+ print "\nPARTIAL MATCH\n" ;
+
+ match "Wa" ;
+ match "A" ;
+ match "a" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+
+ }
+
+ ok(153, docat_del($file) eq <<'EOM') ;
+IN ORDER
+Smith -> John
+Wall -> Larry
+Walls -> Brick
+mouse -> mickey
+
+PARTIAL MATCH
+Wa -> Wall -> Larry
+A -> Smith -> John
+a -> mouse -> mickey
+EOM
+
+}
+
+#{
+# # R_SETCURSOR
+# use strict ;
+# my (%h, $db) ;
+# unlink $Dfile;
+#
+# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+#
+# $h{abc} = 33 ;
+# my $k = "newest" ;
+# my $v = 44 ;
+# my $status = $db->put($k, $v, R_SETCURSOR) ;
+# print "status = [$status]\n" ;
+# ok(157, $status == 0) ;
+# $status = $db->del($k, R_CURSOR) ;
+# print "status = [$status]\n" ;
+# ok(158, $status == 0) ;
+# $k = "newest" ;
+# ok(159, $db->get($k, $v, R_CURSOR)) ;
+#
+# ok(160, keys %h == 1) ;
+#
+# undef $db ;
+# untie %h;
+# unlink $Dfile;
+#}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+ or die "Can't open file: $!\n" ;
+ $h{ABC} = undef;
+ ok(154, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+ or die "Can't open file: $!\n" ;
+ %h = (); ;
+ ok(155, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # When iterating over a tied hash using "each", the key passed to FETCH
+ # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
+ # key in FETCH via a filter_fetch_key method we need to check that the
+ # modified key doesn't get passed to NEXTKEY.
+ # Also Test "keys" & "values" while we are at it.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my $bad_key = 0 ;
+ my %h = () ;
+ my $db ;
+ ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+ $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
+ $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
+
+ $h{'Alpha_ABC'} = 2 ;
+ $h{'Alpha_DEF'} = 5 ;
+
+ ok(157, $h{'Alpha_ABC'} == 2);
+ ok(158, $h{'Alpha_DEF'} == 5);
+
+ my ($k, $v) = ("","");
+ while (($k, $v) = each %h) {}
+ ok(159, $bad_key == 0);
+
+ $bad_key = 0 ;
+ foreach $k (keys %h) {}
+ ok(160, $bad_key == 0);
+
+ $bad_key = 0 ;
+ foreach $v (values %h) {}
+ ok(161, $bad_key == 0);
+
+ undef $db ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # now an error to pass 'compare' a non-code reference
+ my $dbh = new DB_File::BTREEINFO ;
+
+ eval { $dbh->{compare} = 2 };
+ ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/);
+
+ eval { $dbh->{prefix} = 2 };
+ ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/);
+
+}
+
+
+#{
+# # recursion detection in btree
+# my %hash ;
+# unlink $Dfile;
+# my $dbh = new DB_File::BTREEINFO ;
+# $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ;
+#
+#
+# my (%h);
+# ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
+#
+# eval { $hash{1} = 2;
+# $hash{4} = 5;
+# };
+#
+# ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
+# {
+# no warnings;
+# untie %hash;
+# }
+# unlink $Dfile;
+#}
+ok(164,1);
+ok(165,1);
+
+{
+ # Check that two callbacks don't interact
+ my %hash1 ;
+ my %hash2 ;
+ my $h1_count = 0;
+ my $h2_count = 0;
+ unlink $Dfile, $Dfile2;
+ my $dbh1 = new DB_File::BTREEINFO ;
+ $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ;
+
+ my $dbh2 = new DB_File::BTREEINFO ;
+ $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ;
+
+
+
+ my (%h);
+ ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
+ ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
+
+ $hash1{DEFG} = 5;
+ $hash1{XYZ} = 2;
+ $hash1{ABCDE} = 5;
+
+ $hash2{defg} = 5;
+ $hash2{xyz} = 2;
+ $hash2{abcde} = 5;
+
+ ok(168, $h1_count > 0);
+ ok(169, $h1_count == $h2_count);
+
+ ok(170, safeUntie \%hash1);
+ ok(171, safeUntie \%hash2);
+ unlink $Dfile, $Dfile2;
+}
+
+{
+ # Check that DBM Filter can cope with read-only $_
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+ $db->filter_fetch_key (sub { }) ;
+ $db->filter_store_key (sub { }) ;
+ $db->filter_fetch_value (sub { }) ;
+ $db->filter_store_value (sub { }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(173, $h{"fred"} eq "joe");
+
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
+ ok (174, ! $@);
+
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ $h{"fred"} = "joe" ;
+
+ ok(175, $h{"fred"} eq "joe");
+
+ ok(176, $db->FIRSTKEY() eq "fred") ;
+
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
+ ok (177, ! $@);
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # Check low-level API works with filter
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(178, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+
+ $db->filter_fetch_key (sub { $_ = unpack("i", $_) } );
+ $db->filter_store_key (sub { $_ = pack("i", $_) } );
+ $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+ $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+ $_ = 'fred';
+
+ my $key = 22 ;
+ my $value = 34 ;
+
+ $db->put($key, $value) ;
+ ok 179, $key == 22;
+ ok 180, $value == 34 ;
+ ok 181, $_ eq 'fred';
+ #print "k [$key][$value]\n" ;
+
+ my $val ;
+ $db->get($key, $val) ;
+ ok 182, $key == 22;
+ ok 183, $val == 34 ;
+ ok 184, $_ eq 'fred';
+
+ $key = 51 ;
+ $value = 454;
+ $h{$key} = $value ;
+ ok 185, $key == 51;
+ ok 186, $value == 454 ;
+ ok 187, $_ eq 'fred';
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+
+
+{
+ # Regression Test for bug 30237
+ # Check that substr can be used in the key to db_put
+ # and that db_put does not trigger the warning
+ #
+ # Use of uninitialized value in subroutine entry
+
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(188, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+ my $warned = '';
+ local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+ # db-put with substr of key
+ my %remember = () ;
+ for my $ix ( 10 .. 12 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $db->put(substr($key,0), $value) ;
+ }
+
+ ok 189, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # db-put with substr of value
+ $warned = '';
+ for my $ix ( 20 .. 22 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $db->put($key, substr($value,0)) ;
+ }
+
+ ok 190, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied hash is not a problem, but check anyway
+ # substr of key
+ $warned = '';
+ for my $ix ( 30 .. 32 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $h{substr($key,0)} = $value ;
+ }
+
+ ok 191, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied hash is not a problem, but check anyway
+ # substr of value
+ $warned = '';
+ for my $ix ( 40 .. 42 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $h{$key} = substr($value,0) ;
+ }
+
+ ok 192, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ my %bad = () ;
+ $key = '';
+ for ($status = $db->seq($key, $value, R_FIRST ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT ) ) {
+
+ #print "# key [$key] value [$value]\n" ;
+ if (defined $remember{$key} && defined $value &&
+ $remember{$key} eq $value) {
+ delete $remember{$key} ;
+ }
+ else {
+ $bad{$key} = $value ;
+ }
+ }
+
+ ok 193, keys %bad == 0 ;
+ ok 194, keys %remember == 0 ;
+
+ print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key $value\n" while ($key, $value) = each %bad;
+
+ # Make sure this fix does not break code to handle an undef key
+ # Berkeley DB undef key is bron between versions 2.3.16 and
+ my $value = 'fred';
+ $warned = '';
+ $db->put(undef, $value) ;
+ ok 195, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
+ print "# db_ver $DB_File::db_ver\n";
+ $value = '' ;
+ $db->get(undef, $value) ;
+ ok 196, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
+ ok 197, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+exit ;
diff --git a/lang/perl/DB_File/t/db-hash.t b/lang/perl/DB_File/t/db-hash.t
new file mode 100644
index 00000000..f4c8f957
--- /dev/null
+++ b/lang/perl/DB_File/t/db-hash.t
@@ -0,0 +1,1225 @@
+#!./perl
+
+use warnings;
+use strict;
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+}
+
+use DB_File;
+use Fcntl;
+
+print "1..166\n";
+
+unlink glob "__db.*";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+
+ return $result ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ $result = normalise($result) ;
+ unlink $file ;
+ return $result;
+}
+
+sub normalise
+{
+ my $data = shift ;
+ $data =~ s#\r\n#\n#g
+ if $^O eq 'cygwin' ;
+ return $data ;
+}
+
+sub safeUntie
+{
+ my $hashref = shift ;
+ my $no_inner = 1;
+ local $SIG{__WARN__} = sub {-- $no_inner } ;
+ untie %$hashref;
+ return $no_inner;
+}
+
+
+my $Dfile = "dbhash.tmp";
+my $Dfile2 = "dbhash2.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to HASHINFO
+
+my $dbh = new DB_File::HASHINFO ;
+
+ok(1, ! defined $dbh->{bsize}) ;
+ok(2, ! defined $dbh->{ffactor}) ;
+ok(3, ! defined $dbh->{nelem}) ;
+ok(4, ! defined $dbh->{cachesize}) ;
+ok(5, ! defined $dbh->{hash}) ;
+ok(6, ! defined $dbh->{lorder}) ;
+
+$dbh->{bsize} = 3000 ;
+ok(7, $dbh->{bsize} == 3000 );
+
+$dbh->{ffactor} = 9000 ;
+ok(8, $dbh->{ffactor} == 9000 );
+
+$dbh->{nelem} = 400 ;
+ok(9, $dbh->{nelem} == 400 );
+
+$dbh->{cachesize} = 65 ;
+ok(10, $dbh->{cachesize} == 65 );
+
+my $some_sub = sub {} ;
+$dbh->{hash} = $some_sub;
+ok(11, $dbh->{hash} eq $some_sub );
+
+$dbh->{lorder} = 1234 ;
+ok(12, $dbh->{lorder} == 1234 );
+
+# 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 'my $q = $dbh->{fred}' ;
+ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
+
+# Now check the interface to HASH
+my ($X, %h);
+ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+die "Could not tie: $!" unless $X;
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) ||
+ $noMode{$^O} );
+
+my ($key, $value, $i);
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(17, !$i );
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(18, $h{'abc'} eq 'ABC' );
+ok(19, !defined $h{'jimmy'} );
+ok(20, !exists $h{'jimmy'} );
+ok(21, exists $h{'abc'} );
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+
+# tie to the same file again, do not supply a type - should default to HASH
+ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+my @keys = keys(%h);
+my @values = values(%h);
+
+ok(23, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+ok(24, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(25, $#keys == 31) ;
+
+$h{'foo'} = '';
+ok(26, $h{'foo'} eq '' );
+
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+ $h{''} = 'bar';
+ $result = ( $h{''} eq 'bar' );
+}
+else
+ { $result = 1 }
+ok(27, $result) ;
+
+# check cache overflow and numeric keys and contents
+my $ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(28, $ok );
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(29, $size > 0 );
+
+@h{0..200} = 200..400;
+my @foo = @h{0..200};
+ok(30, join(':',200..400) eq join(':',@foo) );
+
+
+# Now check all the non-tie specific stuff
+
+# Check NOOVERWRITE will make put fail when attempting to overwrite
+# an existing record.
+
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(31, $status == 1 );
+
+# check that the value of the key 'x' has not been changed by the
+# previous test
+ok(32, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(33, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(34, $status == 0 );
+ok(35, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(36, $status == 0 );
+
+# Make sure that the key deleted, cannot be retrieved
+{
+ no warnings 'uninitialized' ;
+ ok(37, $h{'q'} eq undef );
+}
+
+# Attempting to delete a non-existent key should fail
+
+$status = $X->del('joe') ;
+ok(38, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(39, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(40, $status == 0 );
+ok(41, $value eq 'A' );
+
+# seq
+# ###
+
+# ditto, but use put to replace the key/value pair.
+
+# use seq to walk backwards through a file - check that this reversed is
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(42, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(43, 1 );
+#ok(43, $status != 0 );
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# clear
+# #####
+
+ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(45, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(46, $i == 0);
+
+untie %h ;
+unlink $Dfile ;
+
+
+# Now try an in memory file
+ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+# fd with an in memory file should return fail
+$status = $X->fd ;
+ok(48, $status == -1 );
+
+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) ;
+}
+
+{
+ # check that attempting to tie an array to a DB_HASH will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
+ ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ our (@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]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
+
+{
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ no warnings 'uninitialized';
+ my($fk, $sk, $fv, $sv) = @_ ;
+
+ print "# Fetch Key : expected '$fk' got '$fetch_key'\n"
+ if $fetch_key ne $fk ;
+ print "# Fetch Value : expected '$fv' got '$fetch_value'\n"
+ if $fetch_value ne $fv ;
+ print "# Store Key : expected '$sk' got '$store_key'\n"
+ if $store_key ne $sk ;
+ print "# Store Value : expected '$sv' got '$store_value'\n"
+ if $store_value ne $sv ;
+ print "# \$_ : expected 'original' got '$_'\n"
+ if $_ ne 'original' ;
+
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(64, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(65, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(66, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ my ($k, $v) ;
+ $k = 'fred';
+ ok(67, ! $db->seq($k, $v, R_FIRST) ) ;
+ ok(68, $k eq "fred") ;
+ ok(69, $v eq "joe") ;
+ # fk sk fv sv
+ ok(70, checkOutput( "fred", "fred", "joe", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(71, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(72, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(73, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $k = 'Fred'; $v ='';
+ ok(74, ! $db->seq($k, $v, R_FIRST) ) ;
+ ok(75, $k eq "FRED") or
+ print "# k [$k]\n" ;
+ ok(76, $v eq "[Jxe]") ;
+ # fk sk fv sv
+ ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(78, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(79, $h{"fred"} eq "joe");
+ ok(80, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ #ok(77, $db->FIRSTKEY() eq "fred") ;
+ $k = 'fred';
+ ok(81, ! $db->seq($k, $v, R_FIRST) ) ;
+ ok(82, $k eq "fred") ;
+ ok(83, $v eq "joe") ;
+ # fk sk fv sv
+ ok(84, checkOutput( "fred", "fred", "joe", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(85, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(86, $h{"fred"} eq "joe");
+ ok(87, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $k = 'fred';
+ ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
+ ok(89, $k eq "fred") ;
+ ok(90, $v eq "joe") ;
+ ok(91, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+
+ unlink $Dfile;
+ ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(93, $result{"store key"} eq "store key - 1: [fred]");
+ ok(94, $result{"store value"} eq "store value - 1: [joe]");
+ ok(95, ! defined $result{"fetch key"} );
+ ok(96, ! defined $result{"fetch value"} );
+ ok(97, $_ eq "original") ;
+
+ ok(98, $db->FIRSTKEY() eq "fred") ;
+ ok(99, $result{"store key"} eq "store key - 1: [fred]");
+ ok(100, $result{"store value"} eq "store value - 1: [joe]");
+ ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(102, ! defined $result{"fetch value"} );
+ ok(103, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(105, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(107, ! defined $result{"fetch value"} );
+ ok(108, $_ eq "original") ;
+
+ ok(109, $h{"fred"} eq "joe");
+ ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(111, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(114, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ unlink $Dfile;
+
+ ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+
+{
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ use DB_File ;
+ our (%h, $k, $v);
+
+ unlink "fruit" ;
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
+ or die "Cannot open file 'fruit': $!\n";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+ unlink "fruit" ;
+ }
+
+ ok(117, docat_del($file) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+ $h{ABC} = undef;
+ ok(118, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+ %h = (); ;
+ ok(119, $a eq "") ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # When iterating over a tied hash using "each", the key passed to FETCH
+ # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
+ # key in FETCH via a filter_fetch_key method we need to check that the
+ # modified key doesn't get passed to NEXTKEY.
+ # Also Test "keys" & "values" while we are at it.
+
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my $bad_key = 0 ;
+ my %h = () ;
+ my $db ;
+ ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+ $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
+ $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
+
+ $h{'Alpha_ABC'} = 2 ;
+ $h{'Alpha_DEF'} = 5 ;
+
+ ok(121, $h{'Alpha_ABC'} == 2);
+ ok(122, $h{'Alpha_DEF'} == 5);
+
+ my ($k, $v) = ("","");
+ while (($k, $v) = each %h) {}
+ ok(123, $bad_key == 0);
+
+ $bad_key = 0 ;
+ foreach $k (keys %h) {}
+ ok(124, $bad_key == 0);
+
+ $bad_key = 0 ;
+ foreach $v (values %h) {}
+ ok(125, $bad_key == 0);
+
+ undef $db ;
+ untie %h ;
+ unlink $Dfile;
+}
+
+{
+ # now an error to pass 'hash' a non-code reference
+ my $dbh = new DB_File::HASHINFO ;
+
+ eval { $dbh->{hash} = 2 };
+ ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);
+
+}
+
+
+#{
+# # recursion detection in hash
+# my %hash ;
+# my $Dfile = "xxx.db";
+# unlink $Dfile;
+# my $dbh = new DB_File::HASHINFO ;
+# $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
+#
+#
+# ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
+#
+# eval { $hash{1} = 2;
+# $hash{4} = 5;
+# };
+#
+# ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
+# {
+# no warnings;
+# untie %hash;
+# }
+# unlink $Dfile;
+#}
+
+#ok(127, 1);
+#ok(128, 1);
+
+{
+ # Check that two hash's don't interact
+ my %hash1 ;
+ my %hash2 ;
+ my $h1_count = 0;
+ my $h2_count = 0;
+ unlink $Dfile, $Dfile2;
+ my $dbh1 = new DB_File::HASHINFO ;
+ $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;
+
+ my $dbh2 = new DB_File::HASHINFO ;
+ $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
+
+
+
+ my (%h);
+ ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
+ ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );
+
+ $hash1{DEFG} = 5;
+ $hash1{XYZ} = 2;
+ $hash1{ABCDE} = 5;
+
+ $hash2{defg} = 5;
+ $hash2{xyz} = 2;
+ $hash2{abcde} = 5;
+
+ ok(129, $h1_count > 0);
+ ok(130, $h1_count == $h2_count);
+
+ ok(131, safeUntie \%hash1);
+ ok(132, safeUntie \%hash2);
+ unlink $Dfile, $Dfile2;
+}
+
+{
+ # Passing undef for flags and/or mode when calling tie could cause
+ # Use of uninitialized value in subroutine entry
+
+
+ my $warn_count = 0 ;
+ #local $SIG{__WARN__} = sub { ++ $warn_count };
+ my %hash1;
+ unlink $Dfile;
+
+ tie %hash1, 'DB_File',$Dfile, undef;
+ ok(133, $warn_count == 0);
+ $warn_count = 0;
+ untie %hash1;
+ unlink $Dfile;
+ tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
+ ok(134, $warn_count == 0);
+ untie %hash1;
+ unlink $Dfile;
+ tie %hash1, 'DB_File',$Dfile, undef, undef;
+ ok(135, $warn_count == 0);
+ $warn_count = 0;
+
+ untie %hash1;
+ unlink $Dfile;
+}
+
+{
+ # Check that DBM Filter can cope with read-only $_
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ $db->filter_fetch_key (sub { }) ;
+ $db->filter_store_key (sub { }) ;
+ $db->filter_fetch_value (sub { }) ;
+ $db->filter_store_value (sub { }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(137, $h{"fred"} eq "joe");
+
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
+ ok (138, ! $@);
+
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ $h{"fred"} = "joe" ;
+
+ ok(139, $h{"fred"} eq "joe");
+
+ ok(140, $db->FIRSTKEY() eq "fred") ;
+
+ eval { my @r= grep { $h{$_} } (1, 2, 3) };
+ ok (141, ! $@);
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # Check low-level API works with filter
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+ $db->filter_fetch_key (sub { $_ = unpack("i", $_) } );
+ $db->filter_store_key (sub { $_ = pack("i", $_) } );
+ $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+ $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+ $_ = 'fred';
+
+ my $key = 22 ;
+ my $value = 34 ;
+
+ $db->put($key, $value) ;
+ ok 143, $key == 22;
+ ok 144, $value == 34 ;
+ ok 145, $_ eq 'fred';
+ #print "k [$key][$value]\n" ;
+
+ my $val ;
+ $db->get($key, $val) ;
+ ok 146, $key == 22;
+ ok 147, $val == 34 ;
+ ok 148, $_ eq 'fred';
+
+ $key = 51 ;
+ $value = 454;
+ $h{$key} = $value ;
+ ok 149, $key == 51;
+ ok 150, $value == 454 ;
+ ok 151, $_ eq 'fred';
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+
+{
+ # Regression Test for bug 30237
+ # Check that substr can be used in the key to db_put
+ # and that db_put does not trigger the warning
+ #
+ # Use of uninitialized value in subroutine entry
+
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+ my $warned = '';
+ local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+ # db-put with substr of key
+ my %remember = () ;
+ for my $ix ( 1 .. 2 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $db->put(substr($key,0), $value) ;
+ }
+
+ ok 153, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # db-put with substr of value
+ $warned = '';
+ for my $ix ( 10 .. 12 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $db->put($key, substr($value,0)) ;
+ }
+
+ ok 154, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied hash is not a problem, but check anyway
+ # substr of key
+ $warned = '';
+ for my $ix ( 30 .. 32 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $h{substr($key,0)} = $value ;
+ }
+
+ ok 155, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied hash is not a problem, but check anyway
+ # substr of value
+ $warned = '';
+ for my $ix ( 40 .. 42 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $h{$key} = substr($value,0) ;
+ }
+
+ ok 156, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ my %bad = () ;
+ $key = '';
+ for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
+ $status == 0 ;
+ $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {
+
+ #print "# key [$key] value [$value]\n" ;
+ if (defined $remember{$key} && defined $value &&
+ $remember{$key} eq $value) {
+ delete $remember{$key} ;
+ }
+ else {
+ $bad{$key} = $value ;
+ }
+ }
+
+ ok 157, keys %bad == 0 ;
+ ok 158, keys %remember == 0 ;
+
+ print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key=>$value\n" while ($key, $value) = each %bad;
+
+ # Make sure this fix does not break code to handle an undef key
+ # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
+ my $value = 'fred';
+ $warned = '';
+ $db->put(undef, $value) ;
+ ok 159, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
+ print "# db_ver $DB_File::db_ver\n";
+ $value = '' ;
+ $db->get(undef, $value) ;
+ ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
+ ok 161, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+{
+ # Check filter + substr
+
+ use warnings ;
+ use strict ;
+ my (%h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+ {
+ $db->filter_fetch_key (sub { lc $_ } );
+ $db->filter_store_key (sub { uc $_ } );
+ $db->filter_fetch_value (sub { lc $_ } );
+ $db->filter_store_value (sub { uc $_ } );
+ }
+
+ $_ = 'fred';
+
+ # db-put with substr of key
+ my %remember = () ;
+ my $status = 0 ;
+ for my $ix ( 1 .. 2 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$key} = $value ;
+ $status += $db->put(substr($key,0), substr($value,0)) ;
+ }
+
+ ok 163, $status == 0 or print "# Status $status\n" ;
+
+ if (1)
+ {
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+ }
+
+ my %bad = () ;
+ my $key = '';
+ my $value = '';
+ for ($status = $db->seq($key, $value, R_FIRST ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT ) ) {
+
+ #print "# key [$key] value [$value]\n" ;
+ if (defined $remember{$key} && defined $value &&
+ $remember{$key} eq $value) {
+ delete $remember{$key} ;
+ }
+ else {
+ $bad{$key} = $value ;
+ }
+ }
+
+ ok 164, $_ eq 'fred';
+ ok 165, keys %bad == 0 ;
+ ok 166, keys %remember == 0 ;
+
+ print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key $value\n" while ($key, $value) = each %bad;
+ undef $db ;
+ untie %h;
+ unlink $Dfile;
+}
+
+exit ;
diff --git a/lang/perl/DB_File/t/db-recno.t b/lang/perl/DB_File/t/db-recno.t
new file mode 100644
index 00000000..bd198dcf
--- /dev/null
+++ b/lang/perl/DB_File/t/db-recno.t
@@ -0,0 +1,1595 @@
+#!./perl -w
+
+use strict;
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+}
+
+use DB_File;
+use Fcntl;
+our ($dbh, $Dfile, $bad_ones, $FA);
+
+# full tied array support started in Perl 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 $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+
+ return $result ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ normalise($result) ;
+ return $result;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ my $result = docat($file);
+ unlink $file ;
+ return $result;
+}
+
+sub safeUntie
+{
+ my $hashref = shift ;
+ my $no_inner = 1;
+ local $SIG{__WARN__} = sub {-- $no_inner } ;
+ untie @$hashref;
+ return $no_inner;
+}
+
+sub bad_one
+{
+ unless ($bad_ones++) {
+ print STDERR <<EOM ;
+#
+# Some older versions of Berkeley DB version 1 will fail db-recno
+# tests 61, 63, 64 and 65.
+EOM
+ if ($^O eq 'darwin'
+ && $Config{db_version_major} == 1
+ && $Config{db_version_minor} == 0
+ && $Config{db_version_patch} == 0) {
+ print STDERR <<EOM ;
+#
+# For example Mac OS X 10.2 (or earlier) has such an old
+# version of Berkeley DB.
+EOM
+ }
+
+ print STDERR <<EOM ;
+#
+# You can safely ignore the errors if you're never going to use the
+# broken functionality (recno databases with a modified bval).
+# Otherwise you'll have to upgrade your DB library.
+#
+# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
+# last versions that were released. Berkeley DB version 2 is continually
+# being updated -- Check out http://www.sleepycat.com/ for more details.
+#
+EOM
+ }
+}
+
+sub normalise
+{
+ return unless $^O eq 'cygwin' ;
+ foreach (@_)
+ { s#\r\n#\n#g }
+}
+
+BEGIN
+{
+ {
+ local $SIG{__DIE__} ;
+ eval { require Data::Dumper ; import Data::Dumper } ;
+ }
+
+ if ($@) {
+ *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ;
+ }
+}
+
+my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms
+my $total_tests = 181 ;
+$total_tests += $splice_tests if $FA ;
+print "1..$total_tests\n";
+
+$Dfile = "recno.tmp";
+unlink $Dfile ;
+
+umask(0);
+
+# Check the interface to RECNOINFO
+
+$dbh = new DB_File::RECNOINFO ;
+ok(1, ! defined $dbh->{bval}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{flags}) ;
+ok(5, ! defined $dbh->{lorder}) ;
+ok(6, ! defined $dbh->{reclen}) ;
+ok(7, ! defined $dbh->{bfname}) ;
+
+$dbh->{bval} = 3000 ;
+ok(8, $dbh->{bval} == 3000 );
+
+$dbh->{cachesize} = 9000 ;
+ok(9, $dbh->{cachesize} == 9000 );
+
+$dbh->{psize} = 400 ;
+ok(10, $dbh->{psize} == 400 );
+
+$dbh->{flags} = 65 ;
+ok(11, $dbh->{flags} == 65 );
+
+$dbh->{lorder} = 123 ;
+ok(12, $dbh->{lorder} == 123 );
+
+$dbh->{reclen} = 1234 ;
+ok(13, $dbh->{reclen} == 1234 );
+
+$dbh->{bfname} = 1234 ;
+ok(14, $dbh->{bfname} == 1234 );
+
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
+
+# Now check the interface to RECNOINFO
+
+my $X ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
+ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
+ || $noMode{$^O} );
+
+#my $l = @h ;
+my $l = $X->length ;
+ok(19, ($FA ? @h == 0 : !$l) );
+
+my @data = qw( a b c d ever f g h i j k longername m n o p) ;
+
+$h[0] = shift @data ;
+ok(20, $h[0] eq 'a' );
+
+my $ i;
+foreach (@data)
+ { $h[++$i] = $_ }
+
+unshift (@data, 'a') ;
+
+ok(21, defined $h[1] );
+ok(22, ! defined $h[16] );
+ok(23, $FA ? @h == @data : $X->length == @data );
+
+
+# Overwrite an entry & check fetch it
+$h[3] = 'replaced' ;
+$data[3] = 'replaced' ;
+ok(24, $h[3] eq 'replaced' );
+
+#PUSH
+my @push_data = qw(added to the end) ;
+($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
+push (@data, @push_data) ;
+ok(25, $h[++$i] eq 'added' );
+ok(26, $h[++$i] eq 'to' );
+ok(27, $h[++$i] eq 'the' );
+ok(28, $h[++$i] eq 'end' );
+
+# POP
+my $popped = pop (@data) ;
+my $value = ($FA ? pop @h : $X->pop) ;
+ok(29, $value eq $popped) ;
+
+# SHIFT
+$value = ($FA ? shift @h : $X->shift) ;
+my $shifted = shift @data ;
+ok(30, $value eq $shifted );
+
+# UNSHIFT
+
+# empty list
+($FA ? unshift @h,() : $X->unshift) ;
+ok(31, ($FA ? @h == @data : $X->length == @data ));
+
+my @new_data = qw(add this to the start of the array) ;
+$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
+unshift (@data, @new_data) ;
+ok(32, $FA ? @h == @data : $X->length == @data );
+ok(33, $h[0] eq "add") ;
+ok(34, $h[1] eq "this") ;
+ok(35, $h[2] eq "to") ;
+ok(36, $h[3] eq "the") ;
+ok(37, $h[4] eq "start") ;
+ok(38, $h[5] eq "of") ;
+ok(39, $h[6] eq "the") ;
+ok(40, $h[7] eq "array") ;
+ok(41, $h[8] eq $data[8]) ;
+
+# Brief test for SPLICE - more thorough 'soak test' is later.
+my @old;
+if ($FA) {
+ @old = splice(@h, 1, 2, qw(bananas just before));
+}
+else {
+ @old = $X->splice(1, 2, qw(bananas just before));
+}
+ok(42, $h[0] eq "add") ;
+ok(43, $h[1] eq "bananas") ;
+ok(44, $h[2] eq "just") ;
+ok(45, $h[3] eq "before") ;
+ok(46, $h[4] eq "the") ;
+ok(47, $h[5] eq "start") ;
+ok(48, $h[6] eq "of") ;
+ok(49, $h[7] eq "the") ;
+ok(50, $h[8] eq "array") ;
+ok(51, $h[9] eq $data[8]) ;
+$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old);
+
+# Now both arrays should be identical
+
+my $ok = 1 ;
+my $j = 0 ;
+foreach (@data)
+{
+ $ok = 0, last if $_ ne $h[$j ++] ;
+}
+ok(52, $ok );
+
+# Neagtive subscripts
+
+# get the last element of the array
+ok(53, $h[-1] eq $data[-1] );
+ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
+
+# get the first element using a negative subscript
+eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
+ok(55, $@ eq "" );
+ok(56, $h[0] eq "abcd" );
+
+# now try to read before the start of the array
+eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
+ok(57, $@ =~ '^Modification of non-creatable array value attempted' );
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+ok(58, safeUntie \@h);
+
+unlink $Dfile;
+
+
+{
+ # Check bval defaults to \n
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ ok(60, safeUntie \@h);
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ ok(61, $x eq "abc\ndef\n\nghi\n") ;
+}
+
+{
+ # Change bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{bval} = "-" ;
+ ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ ok(63, safeUntie \@h);
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc-def--ghi-") ;
+ bad_one() unless $ok ;
+ ok(64, $ok) ;
+}
+
+{
+ # Check R_FIXEDLEN with default bval (space)
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{reclen} = 5 ;
+ ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ ok(66, safeUntie \@h);
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc def ghi ") ;
+ bad_one() unless $ok ;
+ ok(67, $ok) ;
+}
+
+{
+ # Check R_FIXEDLEN with user-defined bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{bval} = "-" ;
+ $dbh->{reclen} = 5 ;
+ ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ ok(69, safeUntie \@h);
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc--def-------ghi--") ;
+ bad_one() unless $ok ;
+ ok(70, $ok) ;
+}
+
+{
+ # check that attempting to tie an associative array to a DB_RECNO will fail
+
+ my $filename = "xyz" ;
+ my %x ;
+ eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
+ ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use warnings ;
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use warnings ;
+ use strict ;
+ our (@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 or die "Could not close: $!";
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(72, $@ eq "") ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+ ' ;
+ die "Could not tie: $!" unless $X;
+
+ main::ok(73, $@ eq "") ;
+
+ my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
+ main::ok(74, $@ eq "") ;
+ main::ok(75, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
+ main::ok(76, $@ eq "") ;
+ main::ok(77, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(78, $@ eq "" ) ;
+ main::ok(79, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok(80, $@ eq "") ;
+ main::ok(81, $ret eq "[[11]]") ;
+
+ undef $X;
+ main::ok(82, main::safeUntie \@h);
+ unlink "SubDB.pm", "recno.tmp" ;
+
+}
+
+{
+
+ # test $#
+ my $self ;
+ unlink $Dfile;
+ ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[2] = "ghi" ;
+ $h[3] = "jkl" ;
+ ok(84, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ ok(85, safeUntie \@h);
+ my $x = docat($Dfile) ;
+ ok(86, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to same length
+ $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ;
+ ok(87, $self)
+ or warn "# $DB_File::Error\n";
+ if ($FA)
+ { $#h = 3 }
+ else
+ { $self->STORESIZE(4) }
+ ok(88, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ ok(89, safeUntie \@h);
+ $x = docat($Dfile) ;
+ ok(90, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to bigger
+ ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 6 }
+ else
+ { $self->STORESIZE(7) }
+ ok(92, $FA ? $#h == 6 : $self->length() == 7) ;
+ undef $self ;
+ ok(93, safeUntie \@h);
+ $x = docat($Dfile) ;
+ ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+
+ # $# sets array smaller
+ ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 2 }
+ else
+ { $self->STORESIZE(3) }
+ ok(96, $FA ? $#h == 2 : $self->length() == 3) ;
+ undef $self ;
+ ok(97, safeUntie \@h);
+ $x = docat($Dfile) ;
+ ok(98, $x eq "abc\ndef\nghi\n") ;
+
+ unlink $Dfile;
+
+
+}
+
+{
+ # DBM Filter tests
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ unlink $Dfile;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+
+ print "# Fetch Key : expected '$fk' got '$fetch_key'\n"
+ if $fetch_key ne $fk ;
+ print "# Fetch Value : expected '$fv' got '$fetch_value'\n"
+ if $fetch_value ne $fv ;
+ print "# Store Key : expected '$sk' got '$store_key'\n"
+ if $store_key ne $sk ;
+ print "# Store Value : expected '$sv' got '$store_value'\n"
+ if $store_value ne $sv ;
+ print "# \$_ : expected 'original' got '$_'\n"
+ if $_ ne 'original' ;
+
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ # fk sk fv sv
+ ok(100, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(101, $h[0] eq "joe");
+ # fk sk fv sv
+ ok(102, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(103, $db->FIRSTKEY() == 0) ;
+ # fk sk fv sv
+ ok(104, checkOutput( 0, "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { ++ $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ *= 2 ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[1] = "Joe" ;
+ # fk sk fv sv
+ ok(105, checkOutput( "", 2, "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(106, $h[1] eq "[Jxe]");
+ # fk sk fv sv
+ ok(107, checkOutput( "", 2, "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(108, $db->FIRSTKEY() == 1) ;
+ # fk sk fv sv
+ ok(109, checkOutput( 1, "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(110, checkOutput( "", 0, "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(111, $h[0] eq "joe");
+ ok(112, checkOutput( "", 0, "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(113, $db->FIRSTKEY() == 0) ;
+ ok(114, checkOutput( 0, "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h[0] = "joe" ;
+ ok(115, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(116, $h[0] eq "joe");
+ ok(117, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(118, $db->FIRSTKEY() == 0) ;
+ ok(119, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ ok(120, safeUntie \@h);
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter with a closure
+
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+
+ unlink $Dfile;
+ ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ ok(122, $result{"store key"} eq "store key - 1: [0]");
+ ok(123, $result{"store value"} eq "store value - 1: [joe]");
+ ok(124, ! defined $result{"fetch key"} );
+ ok(125, ! defined $result{"fetch value"} );
+ ok(126, $_ eq "original") ;
+
+ ok(127, $db->FIRSTKEY() == 0 ) ;
+ ok(128, $result{"store key"} eq "store key - 1: [0]");
+ ok(129, $result{"store value"} eq "store value - 1: [joe]");
+ ok(130, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(131, ! defined $result{"fetch value"} );
+ ok(132, $_ eq "original") ;
+
+ $h[7] = "john" ;
+ ok(133, $result{"store key"} eq "store key - 2: [0 7]");
+ ok(134, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(135, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(136, ! defined $result{"fetch value"} );
+ ok(137, $_ eq "original") ;
+
+ ok(138, $h[0] eq "joe");
+ ok(139, $result{"store key"} eq "store key - 3: [0 7 0]");
+ ok(140, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(141, $result{"fetch key"} eq "fetch key - 1: [0]");
+ ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(143, $_ eq "original") ;
+
+ undef $db ;
+ ok(144, safeUntie \@h);
+ unlink $Dfile;
+}
+
+{
+ # DBM Filter recursion detection
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ unlink $Dfile;
+
+ ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_store_key (sub { $_ = $h[0] }) ;
+
+ eval '$h[1] = 1234' ;
+ ok(146, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ ok(147, safeUntie \@h);
+ unlink $Dfile;
+}
+
+
+{
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ use DB_File ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file 'text': $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $FA ? push @h, "green", "black"
+ : $x->push("green", "black") ;
+
+ my $elements = $FA ? scalar @h : $x->length ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $FA ? pop @h : $x->pop ;
+ print "popped $last\n" ;
+
+ $FA ? unshift @h, "white"
+ : $x->unshift("white") ;
+ my $first = $FA ? shift @h : $x->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ # use a negative index
+ print "The last element is $h[-1]\n" ;
+ print "The 2nd last element is $h[-2]\n" ;
+
+ undef $x ;
+ untie @h ;
+
+ unlink $filename ;
+ }
+
+ ok(148, docat_del($file) eq <<'EOM') ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+The last element is green
+The 2nd last element is yellow
+EOM
+
+ my $save_output = "xyzt" ;
+ {
+ my $redirect = new Redirect $save_output ;
+
+ use warnings FATAL => qw(all);
+ use strict ;
+ our (@h, $H, $file, $i);
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+ unlink $file ;
+ }
+
+ ok(149, docat_del($save_output) eq <<'EOM') ;
+
+ORIGINAL
+0: zero
+1: one
+2: two
+3: three
+4: four
+
+The last record was [four]
+The first record was [zero]
+
+REVERSE
+5: last
+4: three
+3: Newbie
+2: one
+1: New One
+0: first
+
+REVERSE again
+5: last
+4: three
+3: Newbie
+2: one
+1: New One
+0: first
+EOM
+
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use DB_File ;
+
+ unlink $Dfile;
+ my @h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
+ or die "Can't open file: $!\n" ;
+ $h[0] = undef;
+ ok(150, $a eq "") ;
+ ok(151, safeUntie \@h);
+ unlink $Dfile;
+}
+
+{
+ # test that %hash = () doesn't produce the warning
+ # Argument "" isn't numeric in entersub
+ use warnings ;
+ use strict ;
+ use DB_File ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ unlink $Dfile;
+ my @h ;
+
+ tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
+ or die "Can't open file: $!\n" ;
+ @h = (); ;
+ ok(152, $a eq "") ;
+ ok(153, safeUntie \@h);
+ unlink $Dfile;
+}
+
+{
+ # Check that DBM Filter can cope with read-only $_
+
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ unlink $Dfile;
+
+ ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+ $db->filter_fetch_key (sub { }) ;
+ $db->filter_store_key (sub { }) ;
+ $db->filter_fetch_value (sub { }) ;
+ $db->filter_store_value (sub { }) ;
+
+ $_ = "original" ;
+
+ $h[0] = "joe" ;
+ ok(155, $h[0] eq "joe");
+
+ eval { my @r= grep { $h[$_] } (1, 2, 3) };
+ ok (156, ! $@);
+
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ $h[1] = "joe" ;
+
+ ok(157, $h[1] eq "joe");
+
+ eval { my @r= grep { $h[$_] } (1, 2, 3) };
+ ok (158, ! $@);
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
+{
+ # Check low-level API works with filter
+
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(159, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+
+ $db->filter_fetch_key (sub { ++ $_ } );
+ $db->filter_store_key (sub { -- $_ } );
+ $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
+ $db->filter_store_value (sub { $_ = pack("i", $_) } );
+
+ $_ = 'fred';
+
+ my $key = 22 ;
+ my $value = 34 ;
+
+ $db->put($key, $value) ;
+ ok 160, $key == 22;
+ ok 161, $value == 34 ;
+ ok 162, $_ eq 'fred';
+ #print "k [$key][$value]\n" ;
+
+ my $val ;
+ $db->get($key, $val) ;
+ ok 163, $key == 22;
+ ok 164, $val == 34 ;
+ ok 165, $_ eq 'fred';
+
+ $key = 51 ;
+ $value = 454;
+ $h[$key] = $value ;
+ ok 166, $key == 51;
+ ok 167, $value == 454 ;
+ ok 168, $_ eq 'fred';
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
+
+{
+ # Regression Test for bug 30237
+ # Check that substr can be used in the key to db_put
+ # and that db_put does not trigger the warning
+ #
+ # Use of uninitialized value in subroutine entry
+
+
+ use warnings ;
+ use strict ;
+ my (@h, $db) ;
+ my $status ;
+ my $Dfile = "xxy.db";
+ unlink $Dfile;
+
+ ok(169, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO) );
+
+ my $warned = '';
+ local $SIG{__WARN__} = sub {$warned = $_[0]} ;
+
+ # db-put with substr of key
+ my %remember = () ;
+ for my $ix ( 0 .. 2 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{substr($key,0, 1)} = $value ;
+ $db->put(substr($key,0, 1), $value) ;
+ }
+
+ ok 170, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # db-put with substr of value
+ $warned = '';
+ for my $ix ( 3 .. 5 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$ix} = $value ;
+ $db->put($ix, substr($value,0)) ;
+ }
+
+ ok 171, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied array is not a problem, but check anyway
+ # substr of key
+ $warned = '';
+ for my $ix ( 6 .. 8 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{substr($key,0,1)} = $value ;
+ $h[substr($key,0,1)] = $value ;
+ }
+
+ ok 172, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ # via the tied array is not a problem, but check anyway
+ # substr of value
+ $warned = '';
+ for my $ix ( 9 .. 10 )
+ {
+ my $key = $ix . "data" ;
+ my $value = "value$ix" ;
+ $remember{$ix} = $value ;
+ $h[$ix] = substr($value,0) ;
+ }
+
+ ok 173, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+
+ my %bad = () ;
+ my $key = '';
+ for (my $status = $db->seq($key, $value, R_FIRST ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT ) ) {
+
+ #print "# key [$key] value [$value]\n" ;
+ if (defined $remember{$key} && defined $value &&
+ $remember{$key} eq $value) {
+ delete $remember{$key} ;
+ }
+ else {
+ $bad{$key} = $value ;
+ }
+ }
+
+ ok 174, keys %bad == 0 ;
+ ok 175, keys %remember == 0 ;
+
+ print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+ print "# bad -- $key $value\n" while ($key, $value) = each %bad;
+
+ # Make sure this fix does not break code to handle an undef key
+ my $value = 'fred';
+ $warned = '';
+ $status = $db->put(undef, $value) ;
+ ok 176, $status == 0
+ or print "# put failed - status $status\n";
+ ok 177, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ print "# db_ver $DB_File::db_ver\n";
+ $value = '' ;
+ $status = $db->get(undef, $value) ;
+ ok 178, $status == 0
+ or print "# get failed - status $status\n" ;
+ ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ;
+ ok 180, $value eq 'fred' or print "# got [$value]\n" ;
+ ok 181, $warned eq ''
+ or print "# Caught warning [$warned]\n" ;
+ $warned = '';
+
+ undef $db ;
+ untie @h;
+ unlink $Dfile;
+}
+
+# Only test splice if this is a newish version of Perl
+exit unless $FA ;
+
+# Test SPLICE
+
+{
+ # check that the splice warnings are under the same lexical control
+ # as their non-tied counterparts.
+
+ use warnings;
+ use strict;
+
+ my $a = '';
+ my @a = (1);
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ unlink $Dfile;
+ my @tied ;
+
+ tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO
+ or die "Can't open file: $!\n" ;
+
+ # uninitialized offset
+ use warnings;
+ my $offset ;
+ $a = '';
+ splice(@a, $offset);
+ ok(182, $a =~ /^Use of uninitialized value /);
+ $a = '';
+ splice(@tied, $offset);
+ ok(183, $a =~ /^Use of uninitialized value in splice/);
+
+ no warnings 'uninitialized';
+ $a = '';
+ splice(@a, $offset);
+ ok(184, $a eq '');
+ $a = '';
+ splice(@tied, $offset);
+ ok(185, $a eq '');
+
+ # uninitialized length
+ use warnings;
+ my $length ;
+ $a = '';
+ splice(@a, 0, $length);
+ ok(186, $a =~ /^Use of uninitialized value /);
+ $a = '';
+ splice(@tied, 0, $length);
+ ok(187, $a =~ /^Use of uninitialized value in splice/);
+
+ no warnings 'uninitialized';
+ $a = '';
+ splice(@a, 0, $length);
+ ok(188, $a eq '');
+ $a = '';
+ splice(@tied, 0, $length);
+ ok(189, $a eq '');
+
+ # offset past end of array
+ use warnings;
+ $a = '';
+ splice(@a, 3);
+ my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
+ $a = '';
+ splice(@tied, 3);
+ ok(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);
+
+ no warnings 'misc';
+ $a = '';
+ splice(@a, 3);
+ ok(191, $a eq '');
+ $a = '';
+ splice(@tied, 3);
+ ok(192, $a eq '');
+
+ ok(193, safeUntie \@tied);
+ unlink $Dfile;
+}
+
+#
+# These are a few regression tests: bundles of five arguments to pass
+# to test_splice(). The first four arguments correspond to those
+# given to splice(), and the last says which context to call it in
+# (scalar, list or void).
+#
+# The expected result is not needed because we get that by running
+# Perl's built-in splice().
+#
+my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
+ 'rarely', 'paleness' ],
+ -4, -2,
+ [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
+ 'void' ],
+
+ [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
+
+ [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
+ 0, -4,
+ [ 'maids' ],
+ 'void' ],
+
+ [ [ 'visibility', 'pocketful', 'rectangles' ],
+ -10, 0,
+ [ 'garbages' ],
+ 'void' ],
+
+ [ [ 'sleeplessly' ],
+ 8, -4,
+ [ 'Margery', 'clearing', 'repercussion', 'clubs',
+ 'arise' ],
+ 'void' ],
+
+ [ [ 'chastises', 'recalculates' ],
+ 0, 0,
+ [ 'momentariness', 'mediates', 'accents', 'toils',
+ 'regaled' ],
+ 'void' ],
+
+ [ [ 'b', '' ],
+ 9, 8,
+ [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+ 'scalar' ],
+
+ [ [ 'b', '' ],
+ undef, undef,
+ [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+ 'scalar' ],
+
+ [ [ 'riheb' ], -8, undef, [], 'void' ],
+
+ [ [ 'uft', 'qnxs', '' ],
+ 6, -2,
+ [ 'znp', 'mhnkh', 'bn' ],
+ 'void' ],
+ );
+
+my $testnum = 194;
+my $failed = 0;
+my $tmp = "dbr$$";
+foreach my $test (@tests) {
+ my $err = test_splice(@$test);
+ if (defined $err) {
+ print STDERR "# failed: ", Dumper($test);
+ print STDERR "# error: $err\n";
+ $failed = 1;
+ ok($testnum++, 0);
+ }
+ else { ok($testnum++, 1) }
+}
+
+if ($failed) {
+ # Not worth running the random ones
+ print STDERR '# skipping ', $testnum++, "\n";
+}
+else {
+ # A thousand randomly-generated tests
+ $failed = 0;
+ srand(0);
+ foreach (0 .. 1000 - 1) {
+ my $test = rand_test();
+ my $err = test_splice(@$test);
+ if (defined $err) {
+ print STDERR "# failed: ", Dumper($test);
+ print STDERR "# error: $err\n";
+ $failed = 1;
+ print STDERR "# skipping any remaining random tests\n";
+ last;
+ }
+ }
+
+ ok($testnum++, not $failed);
+}
+
+die "testnum ($testnum) != total_tests ($total_tests) + 1"
+ if $testnum != $total_tests + 1;
+
+exit ;
+
+# Subroutines for SPLICE testing
+
+# test_splice()
+#
+# Test the new splice() against Perl's built-in one. The first four
+# parameters are those passed to splice(), except that the lists must
+# be (explicitly) passed by reference, and are not actually modified.
+# (It's just a test!) The last argument specifies the context in
+# which to call the functions: 'list', 'scalar', or 'void'.
+#
+# Returns:
+# undef, if the two splices give the same results for the given
+# arguments and context;
+#
+# an error message showing the difference, otherwise.
+#
+# Reads global variable $tmp.
+#
+sub test_splice {
+ die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5;
+ my ($array, $offset, $length, $list, $context) = @_;
+ my @array = @$array;
+ my @list = @$list;
+
+ unlink $tmp;
+
+ my @h;
+ my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO
+ or die "cannot open $tmp: $!";
+
+ my $i = 0;
+ foreach ( @array ) { $h[$i++] = $_ }
+
+ return "basic DB_File sanity check failed"
+ if list_diff(\@array, \@h);
+
+ # Output from splice():
+ # Returned value (munged a bit), error msg, warnings
+ #
+ my ($s_r, $s_error, @s_warnings);
+
+ my $gather_warning = sub { push @s_warnings, $_[0] };
+ if ($context eq 'list') {
+ my @r;
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ @r = splice @array, $offset, $length, @list;
+ };
+ $s_error = $@;
+ $s_r = \@r;
+ }
+ elsif ($context eq 'scalar') {
+ my $r;
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ $r = splice @array, $offset, $length, @list;
+ };
+ $s_error = $@;
+ $s_r = [ $r ];
+ }
+ elsif ($context eq 'void') {
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ splice @array, $offset, $length, @list;
+ };
+ $s_error = $@;
+ $s_r = [];
+ }
+ else {
+ die "bad context $context";
+ }
+
+ foreach ($s_error, @s_warnings) {
+ chomp;
+ s/ at \S+ line \d+\.$//;
+ # only built-in splice identifies name of uninit value
+ s/(uninitialized value) \$\w+/$1/;
+ }
+
+ # Now do the same for DB_File's version of splice
+ my ($ms_r, $ms_error, @ms_warnings);
+ $gather_warning = sub { push @ms_warnings, $_[0] };
+ if ($context eq 'list') {
+ my @r;
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ @r = splice @h, $offset, $length, @list;
+ };
+ $ms_error = $@;
+ $ms_r = \@r;
+ }
+ elsif ($context eq 'scalar') {
+ my $r;
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ $r = splice @h, $offset, $length, @list;
+ };
+ $ms_error = $@;
+ $ms_r = [ $r ];
+ }
+ elsif ($context eq 'void') {
+ eval {
+ local $SIG{__WARN__} = $gather_warning;
+ splice @h, $offset, $length, @list;
+ };
+ $ms_error = $@;
+ $ms_r = [];
+ }
+ else {
+ die "bad context $context";
+ }
+
+ foreach ($ms_error, @ms_warnings) {
+ chomp;
+ s/ at \S+(\s+\S+)*? line \d+\.?.*//s;
+ }
+
+ return "different errors: '$s_error' vs '$ms_error'"
+ if $s_error ne $ms_error;
+ return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
+ if list_diff($s_r, $ms_r);
+ return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
+ if list_diff(\@array, \@h);
+
+ if ((scalar @s_warnings) != (scalar @ms_warnings)) {
+ return 'different number of warnings';
+ }
+
+ while (@s_warnings) {
+ my $sw = shift @s_warnings;
+ my $msw = shift @ms_warnings;
+
+ if (defined $sw and defined $msw) {
+ $msw =~ s/ \(.+\)$//;
+ $msw =~ s/ in splice$// if $] < 5.006;
+ if ($sw ne $msw) {
+ return "different warning: '$sw' vs '$msw'";
+ }
+ }
+ elsif (not defined $sw and not defined $msw) {
+ # Okay.
+ }
+ else {
+ return "one warning defined, another undef";
+ }
+ }
+
+ undef $H;
+ untie @h;
+
+ open(TEXT, $tmp) or die "cannot open $tmp: $!";
+ @h = <TEXT>; normalise @h; chomp @h;
+ close TEXT or die "cannot close $tmp: $!";
+ return('list is different when re-read from disk: '
+ . Dumper(\@array) . ' vs ' . Dumper(\@h))
+ if list_diff(\@array, \@h);
+
+ unlink $tmp;
+
+ return undef; # success
+}
+
+
+# list_diff()
+#
+# Do two lists differ?
+#
+# Parameters:
+# reference to first list
+# reference to second list
+#
+# Returns true iff they differ. Only works for lists of (string or
+# undef).
+#
+# Surely there is a better way to do this?
+#
+sub list_diff {
+ die 'usage: list_diff(ref to first list, ref to second list)'
+ if @_ != 2;
+ my ($a, $b) = @_;
+ my @a = @$a; my @b = @$b;
+ return 1 if (scalar @a) != (scalar @b);
+ for (my $i = 0; $i < @a; $i++) {
+ my ($ae, $be) = ($a[$i], $b[$i]);
+ if (defined $ae and defined $be) {
+ return 1 if $ae ne $be;
+ }
+ elsif (not defined $ae and not defined $be) {
+ # Two undefined values are 'equal'
+ }
+ else {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+
+# rand_test()
+#
+# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
+# ARRAY or LIST might be empty, and OFFSET or LENGTH might be
+# undefined. Return a 'test' - a listref of these five things.
+#
+sub rand_test {
+ die 'usage: rand_test()' if @_;
+ my @contexts = qw<list scalar void>;
+ my $context = $contexts[int(rand @contexts)];
+ return [ rand_list(),
+ (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+ (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+ rand_list(),
+ $context ];
+}
+
+
+sub rand_list {
+ die 'usage: rand_list()' if @_;
+ my @r;
+
+ while (rand() > 0.1 * (scalar @r + 1)) {
+ push @r, rand_word();
+ }
+ return \@r;
+}
+
+
+sub rand_word {
+ die 'usage: rand_word()' if @_;
+ my $r = '';
+ my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>;
+ while (rand() > 0.1 * (length($r) + 1)) {
+ $r .= $chars[int(rand(scalar @chars))];
+ }
+ return $r;
+}
+
+
diff --git a/lang/perl/DB_File/t/pod.t b/lang/perl/DB_File/t/pod.t
new file mode 100644
index 00000000..230df4bd
--- /dev/null
+++ b/lang/perl/DB_File/t/pod.t
@@ -0,0 +1,18 @@
+eval " use Test::More " ;
+
+if ($@)
+{
+ print "1..0 # Skip: Test::More required for testing POD\n" ;
+ exit 0;
+}
+
+eval "use Test::Pod 1.00";
+
+if ($@)
+{
+ print "1..0 # Skip: Test::Pod 1.00 required for testing POD\n" ;
+ exit 0;
+}
+
+all_pod_files_ok();
+
diff --git a/lang/perl/DB_File/typemap b/lang/perl/DB_File/typemap
new file mode 100644
index 00000000..c46b6851
--- /dev/null
+++ b/lang/perl/DB_File/typemap
@@ -0,0 +1,57 @@
+# typemap for Perl 5 interface to Berkeley
+#
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# last modified 20th June 2004
+# version 1.809
+#
+#################################### DB SECTION
+#
+#
+
+u_int T_U_INT
+DB_File T_PTROBJ
+DBT T_dbtdatum
+DBTKEY T_dbtkeydatum
+
+INPUT
+T_dbtkeydatum
+ {
+ SV * my_sv = $arg;
+ DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+ DBT_clear($var) ;
+ SvGETMAGIC(my_sv) ;
+ if (db->type == DB_RECNO) {
+ if (SvOK(my_sv))
+ Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ;
+ else
+ Value = 1 ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(recno_t);
+ }
+ else if (SvOK(my_sv)) {
+ STRLEN len;
+ $var.data = SvPVbyte(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+T_dbtdatum
+ {
+ SV * my_sv = $arg;
+ DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+ DBT_clear($var) ;
+ SvGETMAGIC(my_sv) ;
+ if (SvOK(my_sv)) {
+ STRLEN len;
+ $var.data = SvPVbyte(my_sv, len);
+ $var.size = (int)len;
+ }
+ }
+
+OUTPUT
+
+T_dbtkeydatum
+ OutputKey($arg, $var)
+T_dbtdatum
+ OutputValue($arg, $var)
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/lang/perl/DB_File/version.c b/lang/perl/DB_File/version.c
new file mode 100644
index 00000000..e01f6f6f
--- /dev/null
+++ b/lang/perl/DB_File/version.c
@@ -0,0 +1,83 @@
+/*
+
+ version.c -- Perl 5 interface to Berkeley DB
+
+ written by Paul Marquess <Paul.Marquess@btinternet.com>
+ last modified 2nd Jan 2002
+ version 1.802
+
+ All comments/suggestions/problems are welcome
+
+ Copyright (c) 1995-2002 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.
+
+ Changes:
+ 1.71 - Support for Berkeley DB version 3.
+ Support for Berkeley DB 2/3's backward compatibility mode.
+ 1.72 - No change.
+ 1.73 - Added support for threading
+ 1.74 - Added Perl core patch 7801.
+
+
+*/
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <db.h>
+
+void
+#ifdef CAN_PROTOTYPE
+__getBerkeleyDBInfo(void)
+#else
+__getBerkeleyDBInfo()
+#endif
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ;
+ SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ;
+ SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ;
+
+#ifdef DB_VERSION_MAJOR
+ int Major, Minor, Patch ;
+
+ (void)db_version(&Major, &Minor, &Patch) ;
+
+ /* Check that the versions of db.h and libdb.a are the same */
+ if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR )
+ /* || Patch != DB_VERSION_PATCH) */
+
+ croak("\nDB_File was build with libdb version %d.%d.%d,\nbut you are attempting to run it with libdb version %d.%d.%d\n",
+ DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH,
+ Major, Minor, Patch) ;
+
+ /* check that libdb is recent enough -- we need 2.3.4 or greater */
+ if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4)))
+ croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
+ Major, Minor, Patch) ;
+
+ {
+ char buffer[40] ;
+ sprintf(buffer, "%d.%d", Major, Minor) ;
+ sv_setpv(version_sv, buffer) ;
+ sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ;
+ sv_setpv(ver_sv, buffer) ;
+ }
+
+#else /* ! DB_VERSION_MAJOR */
+ sv_setiv(version_sv, 1) ;
+ sv_setiv(ver_sv, 1) ;
+#endif /* ! DB_VERSION_MAJOR */
+
+#ifdef COMPAT185
+ sv_setiv(compat_sv, 1) ;
+#else /* ! COMPAT185 */
+ sv_setiv(compat_sv, 0) ;
+#endif /* ! COMPAT185 */
+
+}