BerkeleyDB-0.55/0000755000175000017500000000000012472332224012100 5ustar paulpaulBerkeleyDB-0.55/MANIFEST0000644000175000017500000000200512472332224013226 0ustar paulpaulBerkeleyDB.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/blob.t 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) META.json Module JSON meta-data (added by MakeMaker) BerkeleyDB-0.55/constants.h0000644000175000017500000065307612316005465014307 0ustar paulpaul#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_BLOB 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_LOG_BLOB", 11)) { /* ^ */ #ifdef DB_LOG_BLOB *iv_return = DB_LOG_BLOB; 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_VERB_MVCC 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 'V': if (memEQ(name, "DB_VERB_MVCC", 12)) { /* ^ */ #ifdef DB_VERB_MVCC *iv_return = DB_VERB_MVCC; 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_NOSYNC 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_NOSYNC", 13)) { /* ^ */ #ifdef DB_LOG_NOSYNC *iv_return = DB_LOG_NOSYNC; 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_FAIL 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_STREAM_READ DB_ST_IS_RECNO DB_ST_TOPLEVEL DB_USE_ENVIRON DB_VERB_BACKUP DB_WRITECURSOR DB_XIDDATASIZE LOGREC_LONGARG LOGREC_POINTER */ /* Offset 10 gives the best switch position. */ switch (name[10]) { case 'A': if (memEQ(name, "DB_EID_INVALID", 14)) { /* ^ */ #ifdef DB_EID_INVALID *iv_return = DB_EID_INVALID; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_ENV_NOPANIC", 14)) { /* ^ */ #ifdef DB_ENV_NOPANIC *iv_return = DB_ENV_NOPANIC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_EVENT_PANIC", 14)) { /* ^ */ #ifdef DB_EVENT_PANIC *iv_return = DB_EVENT_PANIC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REGION_ANON", 14)) { /* ^ */ #ifdef DB_REGION_ANON *iv_return = DB_REGION_ANON; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_RENAMEMAGIC", 14)) { /* ^ */ #ifdef DB_RENAMEMAGIC *iv_return = DB_RENAMEMAGIC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': if (memEQ(name, "DB_CURSOR_BULK", 14)) { /* ^ */ #ifdef DB_CURSOR_BULK *iv_return = DB_CURSOR_BULK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'C': if (memEQ(name, "DB_LOCK_RECORD", 14)) { /* ^ */ #ifdef DB_LOCK_RECORD *iv_return = DB_LOCK_RECORD; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_VERB_BACKUP", 14)) { /* ^ */ #ifdef DB_VERB_BACKUP *iv_return = DB_VERB_BACKUP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'D': if (memEQ(name, "DB_BTREEOLDVER", 14)) { /* ^ */ #ifdef DB_BTREEOLDVER *iv_return = DB_BTREEOLDVER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_HEAP_RID_SZ", 14)) { /* ^ */ #ifdef DB_HEAP_RID_SZ *iv_return = DB_HEAP_RID_SZ; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_LOCK_OLDEST", 14)) { /* ^ */ #ifdef DB_LOCK_OLDEST *iv_return = DB_LOCK_OLDEST; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_LOG_NO_DATA", 14)) { /* ^ */ #ifdef DB_LOG_NO_DATA *iv_return = DB_LOG_NO_DATA; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': if (memEQ(name, "DB2_AM_INTEXCL", 14)) { /* ^ */ #ifdef DB2_AM_INTEXCL *iv_return = DB2_AM_INTEXCL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_ST_IS_RECNO", 14)) { /* ^ */ #ifdef DB_ST_IS_RECNO *iv_return = DB_ST_IS_RECNO; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_ST_TOPLEVEL", 14)) { /* ^ */ #ifdef DB_ST_TOPLEVEL *iv_return = DB_ST_TOPLEVEL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'F': if (memEQ(name, "DB_CHKSUM_FAIL", 14)) { /* ^ */ #ifdef DB_CHKSUM_FAIL *iv_return = DB_CHKSUM_FAIL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'G': if (memEQ(name, "DB_ENV_LOGGING", 14)) { /* ^ */ #ifdef DB_ENV_LOGGING *iv_return = DB_ENV_LOGGING; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "LOGREC_LONGARG", 14)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 0) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 0 && \ DB_VERSION_PATCH >= 30) *iv_return = LOGREC_LONGARG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "DB_ENV_APPINIT", 14)) { /* ^ */ #ifdef DB_ENV_APPINIT *iv_return = DB_ENV_APPINIT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_LOCK_SWITCH", 14)) { /* ^ */ #ifdef DB_LOCK_SWITCH *iv_return = DB_LOCK_SWITCH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_MPOOL_DIRTY", 14)) { /* ^ */ #ifdef DB_MPOOL_DIRTY *iv_return = DB_MPOOL_DIRTY; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REGION_INIT", 14)) { /* ^ */ #ifdef DB_REGION_INIT *iv_return = DB_REGION_INIT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_USE_ENVIRON", 14)) { /* ^ */ #ifdef DB_USE_ENVIRON *iv_return = DB_USE_ENVIRON; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': if (memEQ(name, "DB_ENV_LOCKING", 14)) { /* ^ */ #ifdef DB_ENV_LOCKING *iv_return = DB_ENV_LOCKING; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_BULKOVF", 14)) { /* ^ */ #ifdef DB_REP_BULKOVF *iv_return = DB_REP_BULKOVF; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_LOCKOUT", 14)) { /* ^ */ #ifdef DB_REP_LOCKOUT *iv_return = DB_REP_LOCKOUT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "DB_ENV_FAILCHK", 14)) { /* ^ */ #ifdef DB_ENV_FAILCHK *iv_return = DB_ENV_FAILCHK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_ENV_NOFLUSH", 14)) { /* ^ */ #ifdef DB_ENV_NOFLUSH *iv_return = DB_ENV_NOFLUSH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_HANDLE_LOCK", 14)) { /* ^ */ #ifdef DB_HANDLE_LOCK *iv_return = DB_HANDLE_LOCK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_INTERNAL_DB", 14)) { /* ^ */ #ifdef DB_INTERNAL_DB *iv_return = DB_INTERNAL_DB; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_MPOOL_CLEAN", 14)) { /* ^ */ #ifdef DB_MPOOL_CLEAN *iv_return = DB_MPOOL_CLEAN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_OPEN_CALLED", 14)) { /* ^ */ #ifdef DB_OPEN_CALLED *iv_return = DB_OPEN_CALLED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_RECORD_LOCK", 14)) { /* ^ */ #ifdef DB_RECORD_LOCK *iv_return = DB_RECORD_LOCK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'M': if (memEQ(name, "DB_ARCH_REMOVE", 14)) { /* ^ */ #ifdef DB_ARCH_REMOVE *iv_return = DB_ARCH_REMOVE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_AUTO_COMMIT", 14)) { /* ^ */ #ifdef DB_AUTO_COMMIT *iv_return = DB_AUTO_COMMIT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_LOCK_REMOVE", 14)) { /* ^ */ #ifdef DB_LOCK_REMOVE *iv_return = DB_LOCK_REMOVE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'N': if (memEQ(name, "DB_LOCK_RANDOM", 14)) { /* ^ */ #ifdef DB_LOCK_RANDOM *iv_return = DB_LOCK_RANDOM; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REGION_NAME", 14)) { /* ^ */ #ifdef DB_REGION_NAME *iv_return = DB_REGION_NAME; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_EGENCHG", 14)) { /* ^ */ #ifdef DB_REP_EGENCHG *iv_return = DB_REP_EGENCHG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "LOGREC_POINTER", 14)) { /* ^ */ #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 'O': if (memEQ(name, "DB_ENV_DBLOCAL", 14)) { /* ^ */ #ifdef DB_ENV_DBLOCAL *iv_return = DB_ENV_DBLOCAL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_MAX_RECORDS", 14)) { /* ^ */ #ifdef DB_MAX_RECORDS *iv_return = DB_MAX_RECORDS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_RECORDCOUNT", 14)) { /* ^ */ #ifdef DB_RECORDCOUNT *iv_return = DB_RECORDCOUNT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "DB_LOCK_EXPIRE", 14)) { /* ^ */ #ifdef DB_LOCK_EXPIRE *iv_return = DB_LOCK_EXPIRE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REPMGR_PEER", 14)) { /* ^ */ #ifdef DB_REPMGR_PEER *iv_return = DB_REPMGR_PEER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_NOTPERM", 14)) { /* ^ */ #ifdef DB_REP_NOTPERM *iv_return = DB_REP_NOTPERM; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_SEQ_WRAPPED", 14)) { /* ^ */ #ifdef DB_SEQ_WRAPPED *iv_return = DB_SEQ_WRAPPED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'R': if (memEQ(name, "DB_NOOVERWRITE", 14)) { /* ^ */ #ifdef DB_NOOVERWRITE *iv_return = DB_NOOVERWRITE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_NOSERVER_ID", 14)) { /* ^ */ #ifdef DB_NOSERVER_ID *iv_return = DB_NOSERVER_ID; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_STREAM_READ", 14)) { /* ^ */ #ifdef DB_STREAM_READ *iv_return = DB_STREAM_READ; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_WRITECURSOR", 14)) { /* ^ */ #ifdef DB_WRITECURSOR *iv_return = DB_WRITECURSOR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "DB_BACKUP_SIZE", 14)) { /* ^ */ #if (DB_VERSION_MAJOR > 5) || \ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 5 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 15) *iv_return = DB_BACKUP_SIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_CHKSUM_SHA1", 14)) { /* ^ */ #ifdef DB_CHKSUM_SHA1 *iv_return = DB_CHKSUM_SHA1; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_HASHVERSION", 14)) { /* ^ */ #ifdef DB_HASHVERSION *iv_return = DB_HASHVERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_HEAPVERSION", 14)) { /* ^ */ #ifdef DB_HEAPVERSION *iv_return = DB_HEAPVERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_JOIN_NOSORT", 14)) { /* ^ */ #ifdef DB_JOIN_NOSORT *iv_return = DB_JOIN_NOSORT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_LOCKVERSION", 14)) { /* ^ */ #ifdef DB_LOCKVERSION *iv_return = DB_LOCKVERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_ODDFILESIZE", 14)) { /* ^ */ #ifdef DB_ODDFILESIZE *iv_return = DB_ODDFILESIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_OLD_VERSION", 14)) { /* ^ */ #ifdef DB_OLD_VERSION *iv_return = DB_OLD_VERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_NEWSITE", 14)) { /* ^ */ #ifdef DB_REP_NEWSITE *iv_return = DB_REP_NEWSITE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_XIDDATASIZE", 14)) { /* ^ */ #ifdef DB_XIDDATASIZE *iv_return = DB_XIDDATASIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DB_REVSPLITOFF", 14)) { /* ^ */ #ifdef DB_REVSPLITOFF *iv_return = DB_REVSPLITOFF; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'V': if (memEQ(name, "DB_ENV_PRIVATE", 14)) { /* ^ */ #ifdef DB_ENV_PRIVATE *iv_return = DB_ENV_PRIVATE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_REP_UNAVAIL", 14)) { /* ^ */ #ifdef DB_REP_UNAVAIL *iv_return = DB_REP_UNAVAIL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_RUNRECOVERY", 14)) { /* ^ */ #ifdef DB_RUNRECOVERY *iv_return = DB_RUNRECOVERY; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'W': if (memEQ(name, "DB_LOCK_NOWAIT", 14)) { /* ^ */ #ifdef DB_LOCK_NOWAIT *iv_return = DB_LOCK_NOWAIT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '_': if (memEQ(name, "DB_ENCRYPT_AES", 14)) { /* ^ */ #ifdef DB_ENCRYPT_AES *iv_return = DB_ENCRYPT_AES; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_FILE_ID_LEN", 14)) { /* ^ */ #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_SET_TXN_NOW", 14)) { /* ^ */ #ifdef DB_SET_TXN_NOW *iv_return = DB_SET_TXN_NOW; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_SHALLOW_DUP", 14)) { /* ^ */ #ifdef DB_SHALLOW_DUP *iv_return = DB_SHALLOW_DUP; 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_EXIT_FAILCHK 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_STREAM_WRITE 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 'I': if (memEQ(name, "DB_EXIT_FAILCHK", 15)) { /* ^ */ #ifdef DB_EXIT_FAILCHK *iv_return = DB_EXIT_FAILCHK; 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 } if (memEQ(name, "DB_STREAM_WRITE", 15)) { /* ^ */ #ifdef DB_STREAM_WRITE *iv_return = DB_STREAM_WRITE; 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_REPMGR_ISVIEW 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_REPMGR_ISVIEW", 16)) { /* ^ */ #ifdef DB_REPMGR_ISVIEW *iv_return = DB_REPMGR_ISVIEW; 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_MUTEX_DIED DB_EVENT_REP_CLIENT DB_EVENT_REP_MASTER DB_EXIT_FILE_EXISTS DB_FOREIGN_CONFLICT DB_INTERNAL_BLOB_DB DB_LOCK_FREE_LOCKER DB_LOCK_GET_TIMEOUT DB_LOCK_SET_TIMEOUT DB_MUTEX_OWNER_DEAD 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 12 gives the best switch position. */ switch (name[12]) { case 'A': 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 } break; case 'B': if (memEQ(name, "DB_INTERNAL_BLOB_DB", 19)) { /* ^ */ #ifdef DB_INTERNAL_BLOB_DB *iv_return = DB_INTERNAL_BLOB_DB; 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 'C': 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 'D': 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 } 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 } break; case 'E': if (memEQ(name, "DB_EVENT_MUTEX_DIED", 19)) { /* ^ */ #ifdef DB_EVENT_MUTEX_DIED *iv_return = DB_EVENT_MUTEX_DIED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_MUTEX_OWNER_DEAD", 19)) { /* ^ */ #ifdef DB_MUTEX_OWNER_DEAD *iv_return = DB_MUTEX_OWNER_DEAD; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'F': 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 } 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 } break; case 'G': 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_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; case 'I': 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 } 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 'K': 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 } break; case 'L': 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 } 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 'M': 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 } break; case 'N': 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_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 } 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 } 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 } break; case 'O': 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_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_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_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 'R': 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_VERIFY_PARTITION", 19)) { /* ^ */ #ifdef DB_VERIFY_PARTITION *iv_return = DB_VERIFY_PARTITION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': 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 'T': 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 } break; case 'V': 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 '_': 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_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_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_EXIT_FILE_EXISTS", 19)) { /* ^ */ #ifdef DB_EXIT_FILE_EXISTS *iv_return = DB_EXIT_FILE_EXISTS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } 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_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_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; } 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_STREAM_SYNC_WRITE 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 >= 15) *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 >= 15) *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 'W': if (memEQ(name, "DB_STREAM_SYNC_WRITE", 20)) { /* ^ */ #ifdef DB_STREAM_SYNC_WRITE *iv_return = DB_STREAM_SYNC_WRITE; 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_FAILCHK_PANIC 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 'K': if (memEQ(name, "DB_EVENT_FAILCHK_PANIC", 22)) { /* ^ */ #ifdef DB_EVENT_FAILCHK_PANIC *iv_return = DB_EVENT_FAILCHK_PANIC; 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 >= 15) *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_FAILURE_SYMPTOM_SIZE 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 'Y': if (memEQ(name, "DB_FAILURE_SYMPTOM_SIZE", 23)) { /* ^ */ #ifdef DB_FAILURE_SYMPTOM_SIZE *iv_return = DB_FAILURE_SYMPTOM_SIZE; 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_MUTEX_DESCRIBE_STRLEN DB_REPMGR_ACKS_ALL_PEERS DB_REPMGR_CONF_ELECTIONS DB_REP_CONF_AUTOROLLBACK DB_REP_HEARTBEAT_MONITOR */ /* Offset 15 gives the best switch position. */ switch (name[15]) { case 'A': 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_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 'B': if (memEQ(name, "DB_MUTEX_DESCRIBE_STRLEN", 24)) { /* ^ */ #ifdef DB_MUTEX_DESCRIBE_STRLEN *iv_return = DB_MUTEX_DESCRIBE_STRLEN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': 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_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 'P': 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 'R': 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 'T': 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 '_': 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_INQUEUE_FULL 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 'Q': if (memEQ(name, "DB_EVENT_REP_INQUEUE_FULL", 25)) { /* ^ */ #ifdef DB_EVENT_REP_INQUEUE_FULL *iv_return = DB_EVENT_REP_INQUEUE_FULL; 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 DB_REP_CONF_ELECT_LOGLENGTH */ /* Offset 26 gives the best switch position. */ switch (name[26]) { case 'E': if (memEQ(name, "DB_EVENT_REP_MASTER_FAILUR", 26)) { /* E */ #ifdef DB_EVENT_REP_MASTER_FAILURE *iv_return = DB_EVENT_REP_MASTER_FAILURE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'H': if (memEQ(name, "DB_REP_CONF_ELECT_LOGLENGT", 26)) { /* H */ #ifdef DB_REP_CONF_ELECT_LOGLENGTH *iv_return = DB_REP_CONF_ELECT_LOGLENGTH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': if (memEQ(name, "DB_EVENT_REP_WOULD_ROLLBAC", 26)) { /* K */ #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_BROKE", 26)) { /* N */ #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 'T': if (memEQ(name, "DB_REPMGR_CONF_2SITE_STRIC", 26)) { /* T */ #ifdef DB_REPMGR_CONF_2SITE_STRICT *iv_return = DB_REPMGR_CONF_2SITE_STRICT; 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 DB_SET_MUTEX_FAILCHK_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; case 'I': if (memEQ(name, "DB_SET_MUTEX_FAILCHK_TIMEOUT", 28)) { /* ^ */ #ifdef DB_SET_MUTEX_FAILCHK_TIMEOUT *iv_return = DB_SET_MUTEX_FAILCHK_TIMEOUT; 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_FAIL 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_FAILCHK_PANIC DB_EVENT_MUTEX_DIED DB_EVENT_NOT_HANDLED DB_EVENT_NO_SUCH_EVENT DB_EVENT_PANIC DB_EVENT_REG_ALIVE DB_EVENT_REG_PANIC DB_EVENT_REP_AUTOTAKEOVER_FAILED 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_INQUEUE_FULL 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_EXIT_FAILCHK DB_EXIT_FILE_EXISTS DB_EXTENT DB_FAILCHK DB_FAILCHK_ISALIVE DB_FAILURE_SYMPTOM_SIZE 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_BLOB_DB 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_BLOB 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_NOSYNC 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_DESCRIBE_STRLEN DB_MUTEX_LOCKED DB_MUTEX_LOGICAL_LOCK DB_MUTEX_OWNER_DEAD 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_CONF_PREFMAS_CLIENT DB_REPMGR_CONF_PREFMAS_MASTER DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISPEER DB_REPMGR_ISVIEW 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_ELECT_LOGLENGTH 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_MUTEX_FAILCHK_TIMEOUT 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_STREAM_READ DB_STREAM_SYNC_WRITE DB_STREAM_WRITE 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_MVCC 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 >= 15)\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 >= 15)\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 >= 15)\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 >= 15)\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_LONGARG", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 0) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 0 && \\\n DB_VERSION_PATCH >= 30)\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 29: /* Names all of length 29. */ /* DB_REPMGR_CONF_PREFMAS_CLIENT DB_REPMGR_CONF_PREFMAS_MASTER */ /* Offset 28 gives the best switch position. */ switch (name[28]) { case 'R': if (memEQ(name, "DB_REPMGR_CONF_PREFMAS_MASTE", 28)) { /* R */ #ifdef DB_REPMGR_CONF_PREFMAS_MASTER *iv_return = DB_REPMGR_CONF_PREFMAS_MASTER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DB_REPMGR_CONF_PREFMAS_CLIEN", 28)) { /* T */ #ifdef DB_REPMGR_CONF_PREFMAS_CLIENT *iv_return = DB_REPMGR_CONF_PREFMAS_CLIENT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } 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; case 32: if (memEQ(name, "DB_EVENT_REP_AUTOTAKEOVER_FAILED", 32)) { #ifdef DB_EVENT_REP_AUTOTAKEOVER_FAILED *iv_return = DB_EVENT_REP_AUTOTAKEOVER_FAILED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } BerkeleyDB-0.55/BerkeleyDB.pm0000644000175000017500000012321112472332035014406 0ustar paulpaul package BerkeleyDB; # Copyright (c) 1997-2015 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__. use 5.006; use strict; use Carp; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $use_XSLoader); $VERSION = '0.55'; require Exporter; 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_FAIL 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_FAILCHK_PANIC DB_EVENT_MUTEX_DIED DB_EVENT_NOT_HANDLED DB_EVENT_NO_SUCH_EVENT DB_EVENT_PANIC DB_EVENT_REG_ALIVE DB_EVENT_REG_PANIC DB_EVENT_REP_AUTOTAKEOVER_FAILED 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_INQUEUE_FULL 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_EXIT_FAILCHK DB_EXIT_FILE_EXISTS DB_EXTENT DB_FAILCHK DB_FAILCHK_ISALIVE DB_FAILURE_SYMPTOM_SIZE 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_BLOB_DB 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_BLOB 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_NOSYNC 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_DESCRIBE_STRLEN DB_MUTEX_LOCKED DB_MUTEX_LOGICAL_LOCK DB_MUTEX_OWNER_DEAD 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_CONF_PREFMAS_CLIENT DB_REPMGR_CONF_PREFMAS_MASTER DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISPEER DB_REPMGR_ISVIEW 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_ELECT_LOGLENGTH 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_MUTEX_FAILCHK_TIMEOUT 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_STREAM_READ DB_STREAM_SYNC_WRITE DB_STREAM_WRITE 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_MVCC 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_LONGARG 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, BlobThreshold => 0, BlobDir => undef, }, @_) ; 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, # Blob BlobThreshold => 0, BlobDir => 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, # Blob BlobThreshold => 0, BlobDir => 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, # Blob BlobThreshold => 0, BlobDir => 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 c_get_db_stream { my $cursor = shift ; my $addr = $cursor->_c_get_db_stream(@_); my $obj ; $obj = bless [$addr, $cursor] , "BerkeleyDB::DbStream" if $addr ; return $obj ; } sub db_stream { my $db = shift ; my ($addr) = $db->_db_stream(@_) ; my $obj ; $obj = bless [$addr, $db] , "BerkeleyDB::DbStream" if $addr ; return $obj ; } #sub gdbs #{ # my $cursor = shift ; # # my $k = ''; # my $v = ''; # $db->partial_set(0,0) ; # ok $cursor->c_get($k, $v, DB_FIRST) == 0, "set cursor" # or diag "Status is [" . $cursor->status() . "]"; # $db->partial_clear() ; # is $k, "1"; #} 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() ; delete $Object{"$db"}; delete $Count{"$db"}; } return 1 ; } return undef ; } sub DESTROY { my $self = shift ; $self->cds_unlock() ; } package BerkeleyDB::Term ; END { close_everything() ; } package BerkeleyDB ; 1; __END__ BerkeleyDB-0.55/README0000755000175000017500000006053412472331622012774 0ustar paulpaul BerkeleyDB Version 0.55 22nd February 2015 Copyright (c) 1997-2015 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.6.0 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 BerkeleyDB-0.55/ppport.h0000644000175000017500000002130010111656403013565 0ustar paulpaul/* 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_ */ BerkeleyDB-0.55/Changes0000755000175000017500000003725612472331723013416 0ustar paulpaulRevision history for Perl extension BerkeleyDB. 0.55 30 March 2014 * Error opening ErrFile with PerlIO_findFILE [RT =#101883] * Minor updates for BDB 6.1 0.54 9th November 2013 * memory leak in CDS locking routines [RT #90134] 0.53 14th August 2013 * BerkeleyDB-0.52 fails to build on 5.18.1RC3 [RT #87771] * typo fixes [RT #86705] 0.52 7th May 2013 * Updates for BDB 6.0 - Added Blob support - Added BerkeleyDB::DbStream class to interface to Blobs - Added BlobThreshold & BlobDir option to BerkeleyDB::Env constructor - Added BlobThreshold & BlobDir option to Hash, Btree & Heap constructors - Added get_blob_threshold method to BerkeleyDB::Env - Added get_blob_dir method to BerkeleyDB::Env - Added get_blob_threshold method to the Hash, Btree & Heap - Added get_blob_dir method to the Hash, Btree & Heap * Added method $cursor->set_partial * Added method $cursor->partial_clear * $env->lock_detect dies due to incorrect version check [RT #84179] * (Memory leak in db_verify() method. (libdb < 4.2)) [RT #84409] * Fix a few croaks 0.51 19th March 2012 * Rework FETCHSIZE [RT #75691] 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) * set_msgfile API (#46313) * 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 * Transactional rename/remove added. Patch supplied by Zefram 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. BerkeleyDB-0.55/BerkeleyDB.pod0000644000175000017500000023705412472332052014566 0ustar paulpaul=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); $status = $db->get_blob_threshold($t1) ; $status = $db->get_blob_dir($dir) ; $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() ; $stream = $cursor->db_stream() ; $cursor = $db->db_join() ; $status = $cursor->c_get() ; $status = $cursor->c_close() ; $status = $stream->size($S); $status = $stream->read($data, $offset, $size); $status = $stream->write($data, $offset); $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() $status = $env->get_blob_threshold($t1) ; $status = $env->get_blob_dir($dir) ; $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 This Perl module provides an interface to most of the functionality available in Berkeley DB versions 2, 3, 5 and 6. 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 later 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, B, B and B 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 class provides an interface to the Berkeley DB function B in Berkeley DB 2.x or B and Bopen> in Berkeley DB 3.x (or later). 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. 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 with the C 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, ] [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] [ -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 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 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. 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-Eget_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 -BlobThreshold Sets the size threshold that will be used to decide when data is stored as a BLOB. This option must be set for a blobs to be used. This option requires Berkeley DB 6.0 or better. =item -BlobDir The directory where the BLOB objects are stored. If not specified blob files are stores in the environment directoy. This option requires Berkeley DB 6.0 or better. =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, B and B 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 filehandle. 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 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 If any of the files specified do not already exist, create them. B Initialise the Concurrent Access Methods B Initialise the Locking sub-system. B Initialise the Logging sub-system. B Initialize the shared memory buffer pool subsystem. This subsystem should be used whenever an application is using any Berkeley DB access method. B 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 Create a private memory pool; see memp_open. Ignored unless DB_INIT_MPOOL is also specified. B is also specified. B Do not map this database into process memory. B 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 B 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 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 On transaction commit, do not synchronously flush the log; see txn_open. Ignored unless DB_INIT_TXN is also specified. B 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 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 Use the default policy as specified by db_deadlock. B Abort the oldest transaction. B Abort a random transaction involved in the deadlock. B 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 object. See L<"TRANSACTIONS"> for more details of using transactions. This method is deprecated. Access the transaction methods using the B 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 environmet 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 environment, 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 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 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 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 $status = $env->get_blob_threshold($t1) ; Sets the parameter $t1 to the threshold value (in bytes) that is used to determine when a data item is stored as a Blob. =item $status = $env->get_blob_dir($dir) ; Sets the $dir parameter to the directory where blob files are stored. =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 supports the following database formats: =over 5 =item B 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 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 use it instead. =item B The Btree format allows arbitrary key/value pairs to be stored in a B+tree. As with the B 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 TODO. =item B TODO. =item B TODO. =item B 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 class. These will be described in turn in the next sections. =head1 BerkeleyDB::Hash Equivalent to calling B with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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) B 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 When creating a new database, this flag enables the storing of duplicate keys in the database. If B is not specified as well, the duplicates are stored in the order they are created in the database. B Enables the sorting of duplicate keys in the database. Ignored if B 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 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 only supports the standard database methods. See L. =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 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 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 with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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) B 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 When creating a new database, this flag enables the storing of duplicate keys in the database. If B is not specified as well, the duplicates are stored in the order they are created in the database. B Enables the sorting of duplicate keys in the database. Ignored if B 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 supports the following database methods. See also L. 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 with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 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 followed by Bopen> with type B 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 followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # BerkeleyDB::Heap specific [ -HeapSize => number, ] [ -HeapSizeGb => number, ] =head1 BerkeleyDB::Unknown This class is used to open an existing database. Equivalent to calling B with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 Create any underlying files, as necessary. If the files do not already exist and the B flag is not specified, the call will fail. B Not supported by BerkeleyDB. B Opens the database in read-only mode. B Not supported by BerkeleyDB. B 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. 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 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 of the following values: =over 5 =item B When the B flag is specified, B checks for the existence of B the C<$key> B C<$value> in the database. =item B TODO. =back In addition, the following value may be set by bitwise OR'ing it into the B<$flags> parameter: =over 5 =item B TODO =back The variant C 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 will return B. 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 of the following values: =over 5 =item B This flag is only applicable when accessing a B database. TODO. =item B If this flag is specified and C<$key> already exists in the database, the call to B will return B. =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 will delete B 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 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 for details of the methods available when working with cursors. The B<$flags> parameter is optional. If present it must be set to B of the following values: =over 5 =item B 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 $status = $db->get_blob_threshold($t1) ; Sets the parameter $t1 to the threshold value (in bytes) that is used to determine when a data item is stored as a Blob. =head2 $status = $db->get_blob_dir($dir) ; Sets the $dir parameter to the directory where blob files are stored. =head2 $db->type() Returns the type of the database. The possible return code are B for a B database, B for a B database and B for a B database. This method is typically used when a database has been opened with B. =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 explicitly 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 stores the version of the Btree database. Assuming you called B 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. =head2 $status = $db->status() Returns the status of the last C<$db> method called. =head2 $status = $db->truncate($count) Truncates the database 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 for those you don't want. Trailing unused parameters can be omitted. For example, if you only want to use the C<$c_data> parameter to set the C, 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 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 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. =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 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. The C<$flags> parameter must be either C, C or C. When the flags parameter is C 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 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 of the following values: =over 5 =item B 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 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 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 works just like B. If the cursor is already positioned at the last key/value pair, B will return B. =item B 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 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 works just like B. If the cursor is already positioned at the first key/value pair, B will return B. =item B 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 will return B. =item B Set the cursor to point to the key/value pair referenced by B<$key> and return the value in B<$value>. =item B This flag is a variation on the B flag. As well as returning the value, it also returns the key, via B<$key>. When used with a B database the key matched by B 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 Another variation on B. This one returns both the key and the value. =item B TODO. =item B TODO. =back In addition, the following value may be set by bitwise OR'ing it into the B<$flags> parameter: =over 5 =item B 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 of the following values: =over 5 =item B 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. When used with a Recno ... TODO =item B 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. When used with a Recno ... TODO =item B 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 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 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 will return B. 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 =head2 $status = $cursor->c_close() Closes the cursor B<$cursor>. =head2 $stream = $cursor->db_stream($flags); Create a BerkeleyDB::DbStream object to read the blob at the current cursor location. See L for details of the the BerkeleyDB::DbStream object. $flags must be one or more of the following OR'ed together DB_STREAM_READ DB_STREAM_WRITE DB_STREAM_SYNC_WRITE For full information on the flags refer to the Berkeley DB Reference Guide. =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 method on L: 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 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. =head1 BerkeleyDBB::DbStream -- support for BLOB Blob support is available in Berkeley DB starting with version 6.0. Refer to the section "Blob Support" in the Berkeley DB Programmer Reference for details of how Blob supports works. A Blob is access via a BerkeleyDBB::DbStream object. This is created via a cursor object. # Note - error handling not shown below. # Set the key we want my $k = "some key"; # Don't want the value retrieved by the cursor, # so use partial_set to make sure no data is retrieved. my $v = ''; $cursor->partial_set(0,0) ; $cursor->c_get($k, $v, DB_SET) ; $cursor->partial_clear() ; # Now create a stream to the blob my $stream = $cursor->db_stream(DB_STREAM_WRITE) ; # get the size of the blob $stream->size(my $s) ; # Read the first 1k of data from the blob my $data ; $stream->read($data, 0, 1024); A BerkeleyDB::DbStream object has the following methods available: =head2 $status = $stream->size($SIZE); Outputs the length of the Blob in the $SIZE parameter. =head2 $status = $stream->read($data, $offset, $size); Read from the blob. $offset is the number of bytes from the start of the blob to read from. $size if the number of bytes to read. =head2 $status = $stream->write($data, $offset, $flags); Write $data to the blob, starting at offset $offset. Example Below is an example of how to walk through a database when you don't know beforehand which entries are blobs and which are not. while (1) { my $k = ''; my $v = ''; $cursor->partial_set(0,0) ; my $status = $cursor->c_get($k, $v, DB_NEXT) ; $cursor->partial_clear(); last if $status != 0 ; my $stream = $cursor->db_stream(DB_STREAM_WRITE); if (defined $stream) { # It's a Blob $stream->size(my $s) ; } else { # Not a Blob $cursor->c_get($k, $v, DB_CURRENT) ; } } =head1 Berkeley DB Concurrent Data Store (CDS) The Berkeley DB I (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 and L 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 method or the C 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 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 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. 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. 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, is supplied with the BerkeleyDB module for this purpose. Using C, 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 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 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 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 objects for one database within a single process, that process will hold a write-lock on the database until I C objects have been destroyed. As with all write-cursors, you should try to limit the scope of the C 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 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 carry out a write operation using a read-only cursor (i.e. you cannot use C or C) whilst another write-cursor is already active. The workaround for this issue is to just use C instead of C, 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 method or the C method. The locking behaviour of the C or C 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 function, a read cursor will be created to iterate over the database in both of these cases. Where C and C differ is the place where the cursor carries out the iteration through the database. Whilst C carried out a single iteration every time it was invoked, the C and C 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 and C is B 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 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 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 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 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 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 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 in not. To delete a filter pass C 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 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 when writing, and C 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 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. Although B 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. =head1 HISTORY See the Changes file. =head1 AVAILABILITY The most recent version of B can always be found on CPAN (see L for details), in the directory F. The official web site for Berkeley DB is F. =head1 COPYRIGHT Copyright (c) 1997-2015 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 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) 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 Epmqs@cpan.orgE. =head1 SEE ALSO perl(1), DB_File, Berkeley DB. =cut BerkeleyDB-0.55/config.in0000644000175000017500000000244412472332144013702 0ustar paulpaul# Filename: config.in # # written by Paul Marquess # 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 BerkeleyDB-0.55/hints/0000755000175000017500000000000012472332224013225 5ustar paulpaulBerkeleyDB-0.55/hints/solaris.pl0000644000175000017500000000005507223705464015246 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ]; BerkeleyDB-0.55/hints/irix_6_5.pl0000644000175000017500000000006107142125045015202 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ]; BerkeleyDB-0.55/hints/dec_osf.pl0000644000175000017500000000006307421125674015172 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lpthreads" ]; BerkeleyDB-0.55/Makefile.PL0000644000175000017500000000621311210017230014036 0ustar paulpaul#! 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 < '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 ') : () ), ((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 () { 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 BerkeleyDB-0.55/BerkeleyDB.xs0000644000175000017500000047256412472332035014446 0ustar paulpaul/* BerkeleyDB.xs -- Perl 5 interface to Berkeley DB version 2, 3, 4, 5 & 6 written by Paul Marquess All comments/suggestions/problems are welcome Copyright (c) 1997-2015 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. */ #ifdef __cplusplus extern "C" { #endif #define PERL_NO_GET_CONTEXT #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 #if PERL_REVISION == 5 && (PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 4 )) # ifdef SvPVbyte_force # undef SvPVbyte_force # endif # define SvPVbyte_force(sv,lp) SvPV_force(sv,lp) #endif /* Being the Berkeley DB we prefer the (which will be * shortly #included by the ) __attribute__ to the possibly * already defined __attribute__, for example by GNUC or by Perl. */ #undef __attribute__ #ifdef USE_PERLIO # define GetFILEptr(sv) PerlIO_exportFILE(IoIFP(sv_2io(sv)), NULL) #else # define GetFILEptr(sv) IoIFP(sv_2io(sv)) #endif #include /* 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_MAJOR == 2 && DB_VERSION_MINOR >= 2) # define AT_LEAST_DB_2_2 #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 #if DB_VERSION_MAJOR >= 6 # define AT_LEAST_DB_6_0 #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)); u_int32_t bt_maxkey; u_int32_t bt_minkey; #ifdef AT_LEAST_DB_6_0 int (*bt_compare) __P((DB_callback const DBT *, const DBT *, size_t *)); int (*dup_compare) __P((DB_callback const DBT *, const DBT *, size_t *)); #else int (*bt_compare) __P((DB_callback const DBT *, const DBT *)); int (*dup_compare) __P((DB_callback const DBT *, const DBT *)); #endif 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; u_int32_t blob_threshold; char *blob_dir; } 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 { int Status ; #ifdef AT_LEAST_DB_6_0 DB_STREAM * stream ; #endif int active ; u_int32_t partial ; u_int32_t dlen ; u_int32_t doff ; #ifdef DBM_FILTERING SV * filter_fetch_key ; SV * filter_store_key ; SV * filter_fetch_value ; SV * filter_store_value ; int filtering ; #endif } BerkeleyDB_DbStream_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 #ifndef DB_DBT_APPMALLOC #define DB_DBT_APPMALLOC 0 #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 //#ifdef AT_LEAST_DB_6_0 typedef BerkeleyDB_DbStream_type BerkeleyDB__DbStream_type ; typedef BerkeleyDB_DbStream_type * BerkeleyDB__DbStream ; typedef BerkeleyDB_DbStream_type * BerkeleyDB__DbStream__Raw ; //#else //typedef int BerkeleyDB__DbStream_type ; //typedef int * BerkeleyDB__DbStream ; //typedef int * BerkeleyDB__DbStream__Raw ; //#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_B4Blob ; typedef DBT DBTKEY_Br ; typedef DBT DBTKEY_Bpr ; typedef DBT DBTKEY_seq ; typedef DBT DBT_Blob ; 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 #ifndef AT_LEAST_DB_6_0 typedef int db_off_t; #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") ; \ } \ } #define OutputKeyBlob(arg, name) \ { if (RETVAL) \ { \ my_sv_setpvn(arg, name.data, name.size) ; \ 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_DbStream(a) ckActive(a, "DB_STREAM") #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) { #ifdef dTHX dTHX; #endif 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 [%p] in [%p] 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)) ; } #ifdef AT_LEAST_DB_6_0 /* Close All DB_STREAM */ { BerkeleyDB__DbStream db ; HE * he ; I32 len ; HV * hv = perl_get_hv("BerkeleyDB::Term::DbStream", TRUE); int all = 0 ; int closed = 0 ; (void) hv_iterinit(hv) ; Trace(("BerkeleyDB::DbStream::close_all_dbstream \n")) ; while ( (he = hv_iternext(hv)) ) { db = * (BerkeleyDB__DbStream*) hv_iterkey(he, &len) ; Trace((" Closing DbStream [%p] in [%p] Active [%d]\n", db->stream, db, db->active)); if (db->active) { (db->stream->close)(db->stream, 0); ++ closed ; } db->active = FALSE ; ++ all ; } Trace(("End of BerkeleyDB::Term::close_all_dbstream closed %d of %d streams\n",closed, all)) ; } #endif /* 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 [%p] in [%p] 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 [%p] in [%p] 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 [%p] in [%p] 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) { #ifdef dTHX dTHX; #endif 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) ; /* Silence warning if -Werror=format-security enabled */ croak("%s", buffer2); /* NOTREACHED */ va_end(args); return 1 ; } static I32 GetArrayLength(BerkeleyDB db) { I32 RETVAL = 0 ; #ifndef AT_LEAST_DB_3_1 DBT key ; DBT value ; 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) ; #else DB_BTREE_STAT * stat ; #ifdef AT_LEAST_DB_4_3 db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, 0) ; #else #ifdef AT_LEAST_DB_3_3 db->Status = ((db->dbp)->stat)(db->dbp, &stat, 0) ; #else db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, 0) ; #endif #endif if (db->Status == 0) { RETVAL = (I32)stat->bt_nkeys ; } Trace(("GetArrayLength got %d\n", stat->bt_nkeys)) ; return (RETVAL); #endif } static I32 GetQueueLength(BerkeleyDB db) { #ifndef AT_LEAST_DB_3_3 return 0; #else I32 RETVAL = 0 ; DB_QUEUE_STAT * stat ; #ifdef AT_LEAST_DB_4_3 db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, 0) ; #else #ifdef AT_LEAST_DB_3_3 db->Status = ((db->dbp)->stat)(db->dbp, &stat, 0) ; #else db->Status = ((db->dbp)->stat)(db->dbp, &stat, safemalloc, 0) ; #endif #endif if (db->Status == 0) { RETVAL = (I32)stat->qs_nkeys ; } Trace(("GetQueueLength got %d\n", stat->qs_nkeys)) ; return (RETVAL); #endif } #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 #ifdef AT_LEAST_DB_6_0 btree_compare(DB_callback const DBT * key1, const DBT * key2, size_t * locp) #else btree_compare(DB_callback const DBT * key1, const DBT * key2 ) #endif { #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 #ifdef AT_LEAST_DB_6_0 dup_compare(DB_callback const DBT * key1, const DBT * key2, size_t *locp ) #else dup_compare(DB_callback const DBT * key1, const DBT * key2 ) #endif { #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 ; int retval ; int count ; SV * skey_SV ; STRLEN skey_len; char * skey_ptr ; 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, (char*)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, (char*)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, (char*)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 ; int retval ; int count ; SV * skey_SV ; 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 ; SV * changed_SV ; STRLEN skey_len; char * skey_ptr ; 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 ; SV * changed_SV ; 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 { #ifdef dTHX dTHX; #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) { #ifdef dTHX dTHX; #endif 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) { #ifdef dTHX dTHX; #endif 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) { #ifdef dTHX dTHX; #endif 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) { #ifdef dTHX dTHX; #endif 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) { #ifdef dTHX dTHX; #endif 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 ) { #ifdef dTHX dTHX; #endif 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 [%p] 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 [%p] 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 [%p] 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 } if (info->blob_threshold) #ifndef AT_LEAST_DB_6_0 softCrash("-BlobThreshold needs Berkeley DB 6.0 or better") ; #else { Status = dbp->set_blob_threshold(dbp, info->blob_threshold, 0); Trace(("ENV->set_blob_threshold value = %d returned %s\n", info->blob_threshold, my_db_strerror(Status))) ; if (Status) return RETVAL ; } #endif /* ! AT_LEAST_DB_6_0 */ if (info->blob_dir) #ifndef AT_LEAST_DB_6_0 softCrash("-BlobDir needs Berkeley DB 6.0 or better") ; #else { Status = dbp->set_blob_dir(dbp, info->blob_dir); Trace(("ENV->set_blob_dir value = %s returned %s\n", info->blob_dir, my_db_strerror(Status))) ; if (Status) return RETVAL ; } #endif /* ! AT_LEAST_DB_6_0 */ /* 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) ; #ifndef AT_LEAST_DB_4_2 dbp->close(dbp, 0) ; #endif } 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->open 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); #endif OUTPUT: RETVAL int set_blob_threshold(env, bytes, flags=0) BerkeleyDB::Env env u_int32_t bytes u_int32_t flags PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$env->set_blob_threshold needs Berkeley DB 6.0 or better") ; #else RETVAL = env->Env->set_blob_threshold(env->Env, bytes, flags); #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 ; int blob_threshold = 0 ; char* blob_dir = 0; SV * errprefix = NULL; DB_ENV * env ; int status ; Trace(("in _db_appinit [%s] %p\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_iv(blob_threshold, "BlobThreshold") ; SetValue_pv(blob_dir, "BlobDir", char*) ; 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 */ #ifndef AT_LEAST_DB_6_0 if (blob_threshold) softCrash("-BlobThreshold needs Berkeley DB 6.0 or better") ; if (blob_dir) softCrash("-BlobDir needs Berkeley DB 6.0 or better") ; #endif /* ! AT_LEAST_DB_6_0 */ Trace(("_db_appinit(config=[%p], home=[%s],errprefix=[%p],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: %s", 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 [%ld] 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 #ifdef AT_LEAST_DB_6_0 if (blob_threshold && status == 0) { status = env->set_blob_threshold(env, blob_threshold, 0); Trace(("ENV->set_blob_threshold value = %d returned %s\n", blob_threshold, my_db_strerror(status))) ; } if (blob_dir && status == 0) { status = env->set_blob_dir(env, blob_dir); Trace(("ENV->set_blob_dir value = %s returned %s\n", blob_dir, 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: %s", 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: %s", 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=%p,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 %p, 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 %p Env %p 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_4 softCrash("$env->lock_detect needs Berkeley DB 4.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 DualType get_blob_threshold(env, bytes) BerkeleyDB::Env env u_int32_t bytes = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$env->get_blob_threshold needs Berkeley DB 6.0 or better") ; #else RETVAL = env->Env->get_blob_threshold(env->Env, &bytes); #endif OUTPUT: RETVAL bytes DualType get_blob_dir(env, dir) BerkeleyDB::Env env char* dir = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$env->get_blob_dir needs Berkeley DB 6.0 or better") ; #else RETVAL = env->Env->get_blob_dir(env->Env, (const char**)&dir); #endif OUTPUT: RETVAL dir 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") ; #ifdef AT_LEAST_DB_6_0 SetValue_iv(info.blob_threshold, "BlobThreshold") ; SetValue_pv(info.blob_dir, "BlobDir", char*) ; #endif 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") ; #ifdef AT_LEAST_DB_6_0 SetValue_iv(info.blob_threshold, "BlobThreshold") ; SetValue_pv(info.blob_dir, "BlobDir", char*) ; #endif 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") ; #ifdef AT_LEAST_DB_6_0 SetValue_iv(info.blob_threshold, "BlobThreshold") ; SetValue_pv(info.blob_dir, "BlobDir", char*) ; #endif 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 %p\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 %p 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, (char*)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, (char*)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, (char*)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, (char*)key.data, data.size, (char*)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) ; DualType get_blob_threshold(db, bytes) BerkeleyDB::Common db u_int32_t bytes = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$db->get_blob_threshold needs Berkeley DB 6.0 or better") ; #else RETVAL = db->dbp->get_blob_threshold(db->dbp, &bytes); #endif OUTPUT: RETVAL bytes DualType get_blob_dir(db, dir) BerkeleyDB::Common db char* dir = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$db->get_blob_dir needs Berkeley DB 6.0 or better") ; #else RETVAL = db->dbp->get_blob_dir(db->dbp, (const char**)&dir); #endif OUTPUT: RETVAL dir 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 %p 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 [%p] 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 [%p] 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 void partial_set(db, offset, length) BerkeleyDB::Cursor db u_int32_t offset u_int32_t length PREINIT: dMY_CXT; INIT: ckActive_Cursor(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::Cursor db PREINIT: dMY_CXT; INIT: ckActive_Cursor(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 ; BerkeleyDB::DbStream::Raw _db_stream(db, flags) BerkeleyDB::Cursor db u_int32_t flags BerkeleyDB::DbStream RETVAL = NULL ; PREINIT: dMY_CXT; INIT: saveCurrentDB(db->parent_db); ckActive_Cursor(db->active) ; CODE: { #ifndef AT_LEAST_DB_6_0 softCrash("db_stream needs at least Berkeley DB 6.0.x"); #else DB_STREAM * stream = NULL ; db->Status = ((db->cursor)->db_stream)(db->cursor, &stream, flags) ; if (db->Status == 0){ ZMALLOC(RETVAL, BerkeleyDB__DbStream_type) ; RETVAL->stream = stream ; RETVAL->active = TRUE ; hash_store_iv("BerkeleyDB::Term::DbStream", (char *)RETVAL, 1) ; } else { Trace(("db_stream [%s]\n", my_db_strerror(db->Status))); } #endif } OUTPUT: RETVAL BerkeleyDB::DbStream::Raw _c_get_db_stream(db, key, cflags, sflags) BerkeleyDB::Cursor db DBTKEY_B4Blob key u_int32_t cflags u_int32_t sflags BerkeleyDB::DbStream RETVAL = NULL ; PREINIT: dMY_CXT; INIT: saveCurrentDB(db->parent_db); ckActive_Cursor(db->active) ; CODE: { #ifndef AT_LEAST_DB_6_0 softCrash("db_stream needs at least Berkeley DB 6.0.x"); #else DBT data; DB_STREAM * stream = NULL ; DBT_clear(data); data.flags = DB_DBT_PARTIAL; db->Status = (db->cursor->c_get)(db->cursor, &key, &data, cflags); if (db->Status == 0) db->Status = ((db->cursor)->db_stream)(db->cursor, &stream, sflags) ; /* if (db->Status == EINVAL){ db->Status = (db->cursor->c_get)(db->cursor,&key,&data,DB_CURRENT) ; } */ if (db->Status == 0){ ZMALLOC(RETVAL, BerkeleyDB__DbStream_type) ; RETVAL->stream = stream ; RETVAL->active = TRUE ; hash_store_iv("BerkeleyDB::Term::DbStream", (char *)RETVAL, 1) ; } else { Trace(("db_stream [%s]\n", my_db_strerror(db->Status))); } #endif } OUTPUT: RETVAL key MODULE = BerkeleyDB::DbStream PACKAGE = BerkeleyDB::DbStream PREFIX = xx_ void DESTROY(dbstream) BerkeleyDB::DbStream dbstream PREINIT: dMY_CXT; CODE: Trace(("In BerkeleyDB::DbStream::_DESTROY db %p active=%d\n", dbstream, dbstream->active)); hash_delete("BerkeleyDB::Term::DbStream", (char *)dbstream) ; #ifdef AT_LEAST_DB_6_0 if (dbstream->active) ((dbstream->stream)->close)(dbstream->stream, 0) ; Safefree(dbstream) ; #endif Trace(("End of BerkeleyDB::DbStream::_DESTROY\n")) ; DualType close(dbstream, flags=0) BerkeleyDB::DbStream dbstream u_int32_t flags PREINIT: dMY_CXT; INIT: ckActive_DbStream(dbstream->active) ; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$dbstream->close needs Berkeley DB 6.0 or better") ; #else RETVAL = (dbstream->stream->close)(dbstream->stream, flags); dbstream->active = FALSE; hash_delete("BerkeleyDB::Term::DbStream", (char *)dbstream) ; #endif OUTPUT: RETVAL DualType read(db, data, offset, size, flags=0) BerkeleyDB::DbStream db DBT_Blob data db_off_t offset u_int32_t size u_int32_t flags PREINIT: dMY_CXT; INIT: ckActive_DbStream(db->active) ; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$dbstream->read needs Berkeley DB 6.0 or better") ; #else data.data = Sv_Grow(ST(1), size); data.ulen = size > data.ulen ? size : data.ulen ; RETVAL = (db->stream->read)(db->stream, &data, offset, size, flags); Trace(("stream->read [%s]\n", my_db_strerror(db->Status))); #endif OUTPUT: RETVAL data DualType write(db, data, offset=0, flags=0) BerkeleyDB::DbStream db DBT data db_off_t offset u_int32_t flags PREINIT: dMY_CXT; INIT: ckActive_DbStream(db->active) ; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$dbstream->write needs Berkeley DB 6.0 or better") ; #else RETVAL = (db->stream->write)(db->stream, &data, offset, flags); #endif OUTPUT: RETVAL DualType size(dbstream, size, flags=0) BerkeleyDB::DbStream dbstream db_off_t size = NO_INIT u_int32_t flags PREINIT: dMY_CXT; INIT: ckActive_DbStream(dbstream->active) ; CODE: #ifndef AT_LEAST_DB_6_0 softCrash("$dbstream->size needs Berkeley DB 6.0 or better") ; #else RETVAL = dbstream->stream->size(dbstream->stream, &size, flags); #endif OUTPUT: RETVAL size 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 [%p] in [%p]\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 [%p] 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 (db->Status == DB_NOTFOUND) { ((db->cursor)->c_close)(db->cursor) ; db->cursor = NULL ; } ST(0) = sv_newmortal(); OutputKey(ST(0), key) } MODULE = BerkeleyDB::Recno PACKAGE = BerkeleyDB::Recno I32 FETCHSIZE(db) BerkeleyDB::Common db PREINIT: dMY_CXT; CODE: saveCurrentDB(db) ; RETVAL = GetArrayLength(db) ; OUTPUT: RETVAL MODULE = BerkeleyDB::Queue PACKAGE = BerkeleyDB::Queue I32 FETCHSIZE(db) BerkeleyDB::Common db PREINIT: dMY_CXT; CODE: saveCurrentDB(db) ; RETVAL = GetQueueLength(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 ; } BerkeleyDB-0.55/BerkeleyDB/0000755000175000017500000000000012472332224014050 5ustar paulpaulBerkeleyDB-0.55/BerkeleyDB/Hash.pm0000644000175000017500000000012706755343420015300 0ustar paulpaul package BerkeleyDB::Hash ; # This file is only used for MLDBM use BerkeleyDB ; 1 ; BerkeleyDB-0.55/BerkeleyDB/Btree.pm0000644000175000017500000000013006755343374015460 0ustar paulpaul package BerkeleyDB::Btree ; # This file is only used for MLDBM use BerkeleyDB ; 1 ; BerkeleyDB-0.55/scan.pl0000644000175000017500000001324712123624370013367 0ustar paulpaul#!/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; # | ??>| }| } 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 = ; 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__ BerkeleyDB-0.55/BerkeleyDB.pod.P0000755000175000017500000022304412472331765014773 0ustar paulpaul=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); $status = $db->get_blob_threshold($t1) ; $status = $db->get_blob_dir($dir) ; $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() ; $stream = $cursor->db_stream() ; $cursor = $db->db_join() ; $status = $cursor->c_get() ; $status = $cursor->c_close() ; $status = $stream->size($S); $status = $stream->read($data, $offset, $size); $status = $stream->write($data, $offset); $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() $status = $env->get_blob_threshold($t1) ; $status = $env->get_blob_dir($dir) ; $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 This Perl module provides an interface to most of the functionality available in Berkeley DB versions 2, 3, 5 and 6. 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 later 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, B, B and B 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 class provides an interface to the Berkeley DB function B in Berkeley DB 2.x or B and Bopen> in Berkeley DB 3.x (or later). 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. 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 with the C 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, ] [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] [ -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 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 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. 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-Eget_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 -BlobThreshold Sets the size threshold that will be used to decide when data is stored as a BLOB. This option must be set for a blobs to be used. This option requires Berkeley DB 6.0 or better. =item -BlobDir The directory where the BLOB objects are stored. If not specified blob files are stores in the environment directoy. This option requires Berkeley DB 6.0 or better. =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, B and B 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 filehandle. 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 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 If any of the files specified do not already exist, create them. B Initialise the Concurrent Access Methods B Initialise the Locking sub-system. B Initialise the Logging sub-system. B Initialize the shared memory buffer pool subsystem. This subsystem should be used whenever an application is using any Berkeley DB access method. B 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 Create a private memory pool; see memp_open. Ignored unless DB_INIT_MPOOL is also specified. B is also specified. B Do not map this database into process memory. B 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 B 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 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 On transaction commit, do not synchronously flush the log; see txn_open. Ignored unless DB_INIT_TXN is also specified. B 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 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 Use the default policy as specified by db_deadlock. B Abort the oldest transaction. B Abort a random transaction involved in the deadlock. B 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 object. See L<"TRANSACTIONS"> for more details of using transactions. This method is deprecated. Access the transaction methods using the B 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 environmet 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 environment, 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 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 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 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 $status = $env->get_blob_threshold($t1) ; Sets the parameter $t1 to the threshold value (in bytes) that is used to determine when a data item is stored as a Blob. =item $status = $env->get_blob_dir($dir) ; Sets the $dir parameter to the directory where blob files are stored. =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 supports the following database formats: =over 5 =item B 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 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 use it instead. =item B The Btree format allows arbitrary key/value pairs to be stored in a B+tree. As with the B 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 TODO. =item B TODO. =item B TODO. =item B 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 class. These will be described in turn in the next sections. =head1 BerkeleyDB::Hash Equivalent to calling B with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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) B 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 When creating a new database, this flag enables the storing of duplicate keys in the database. If B is not specified as well, the duplicates are stored in the order they are created in the database. B Enables the sorting of duplicate keys in the database. Ignored if B 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 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 only supports the standard database methods. See L. =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 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 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 with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # 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) B 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 When creating a new database, this flag enables the storing of duplicate keys in the database. If B is not specified as well, the duplicates are stored in the order they are created in the database. B Enables the sorting of duplicate keys in the database. Ignored if B 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 supports the following database methods. See also L. 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 with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 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 followed by Bopen> with type B 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 followed by Bopen> with type B 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 }, ], [ -BlobThreshold=> $number, ] [ -BlobDir => directory, ] # BerkeleyDB::Heap specific [ -HeapSize => number, ] [ -HeapSizeGb => number, ] =head1 BerkeleyDB::Unknown This class is used to open an existing database. Equivalent to calling B with type B in Berkeley DB 2.x and calling B followed by Bopen> with type B 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 Create any underlying files, as necessary. If the files do not already exist and the B flag is not specified, the call will fail. B Not supported by BerkeleyDB. B Opens the database in read-only mode. B Not supported by BerkeleyDB. B 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. 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 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 of the following values: =over 5 =item B When the B flag is specified, B checks for the existence of B the C<$key> B C<$value> in the database. =item B TODO. =back In addition, the following value may be set by bitwise OR'ing it into the B<$flags> parameter: =over 5 =item B TODO =back The variant C 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 will return B. 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 of the following values: =over 5 =item B This flag is only applicable when accessing a B database. TODO. =item B If this flag is specified and C<$key> already exists in the database, the call to B will return B. =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 will delete B 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 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 for details of the methods available when working with cursors. The B<$flags> parameter is optional. If present it must be set to B of the following values: =over 5 =item B 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 $status = $db->get_blob_threshold($t1) ; Sets the parameter $t1 to the threshold value (in bytes) that is used to determine when a data item is stored as a Blob. =head2 $status = $db->get_blob_dir($dir) ; Sets the $dir parameter to the directory where blob files are stored. =head2 $db->type() Returns the type of the database. The possible return code are B for a B database, B for a B database and B for a B database. This method is typically used when a database has been opened with B. =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 explicitly 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 stores the version of the Btree database. Assuming you called B 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. =head2 $status = $db->status() Returns the status of the last C<$db> method called. =head2 $status = $db->truncate($count) Truncates the database 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 for those you don't want. Trailing unused parameters can be omitted. For example, if you only want to use the C<$c_data> parameter to set the C, 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 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 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. =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 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. The C<$flags> parameter must be either C, C or C. When the flags parameter is C 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 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 of the following values: =over 5 =item B 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 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 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 works just like B. If the cursor is already positioned at the last key/value pair, B will return B. =item B 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 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 works just like B. If the cursor is already positioned at the first key/value pair, B will return B. =item B 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 will return B. =item B Set the cursor to point to the key/value pair referenced by B<$key> and return the value in B<$value>. =item B This flag is a variation on the B flag. As well as returning the value, it also returns the key, via B<$key>. When used with a B database the key matched by B 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 Another variation on B. This one returns both the key and the value. =item B TODO. =item B TODO. =back In addition, the following value may be set by bitwise OR'ing it into the B<$flags> parameter: =over 5 =item B 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 of the following values: =over 5 =item B 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. When used with a Recno ... TODO =item B 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. When used with a Recno ... TODO =item B 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 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 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 will return B. 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 =head2 $status = $cursor->c_close() Closes the cursor B<$cursor>. =head2 $stream = $cursor->db_stream($flags); Create a BerkeleyDB::DbStream object to read the blob at the current cursor location. See L for details of the the BerkeleyDB::DbStream object. $flags must be one or more of the following OR'ed together DB_STREAM_READ DB_STREAM_WRITE DB_STREAM_SYNC_WRITE For full information on the flags refer to the Berkeley DB Reference Guide. =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 method on L: 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 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. =head1 BerkeleyDBB::DbStream -- support for BLOB Blob support is available in Berkeley DB starting with version 6.0. Refer to the section "Blob Support" in the Berkeley DB Programmer Reference for details of how Blob supports works. A Blob is access via a BerkeleyDBB::DbStream object. This is created via a cursor object. # Note - error handling not shown below. # Set the key we want my $k = "some key"; # Don't want the value retrieved by the cursor, # so use partial_set to make sure no data is retrieved. my $v = ''; $cursor->partial_set(0,0) ; $cursor->c_get($k, $v, DB_SET) ; $cursor->partial_clear() ; # Now create a stream to the blob my $stream = $cursor->db_stream(DB_STREAM_WRITE) ; # get the size of the blob $stream->size(my $s) ; # Read the first 1k of data from the blob my $data ; $stream->read($data, 0, 1024); A BerkeleyDB::DbStream object has the following methods available: =head2 $status = $stream->size($SIZE); Outputs the length of the Blob in the $SIZE parameter. =head2 $status = $stream->read($data, $offset, $size); Read from the blob. $offset is the number of bytes from the start of the blob to read from. $size if the number of bytes to read. =head2 $status = $stream->write($data, $offset, $flags); Write $data to the blob, starting at offset $offset. Example Below is an example of how to walk through a database when you don't know beforehand which entries are blobs and which are not. while (1) { my $k = ''; my $v = ''; $cursor->partial_set(0,0) ; my $status = $cursor->c_get($k, $v, DB_NEXT) ; $cursor->partial_clear(); last if $status != 0 ; my $stream = $cursor->db_stream(DB_STREAM_WRITE); if (defined $stream) { # It's a Blob $stream->size(my $s) ; } else { # Not a Blob $cursor->c_get($k, $v, DB_CURRENT) ; } } =head1 Berkeley DB Concurrent Data Store (CDS) The Berkeley DB I (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 and L 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 method or the C 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 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 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. 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. 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, is supplied with the BerkeleyDB module for this purpose. Using C, 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 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 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 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 objects for one database within a single process, that process will hold a write-lock on the database until I C objects have been destroyed. As with all write-cursors, you should try to limit the scope of the C 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 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 carry out a write operation using a read-only cursor (i.e. you cannot use C or C) whilst another write-cursor is already active. The workaround for this issue is to just use C instead of C, 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 method or the C method. The locking behaviour of the C or C 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 function, a read cursor will be created to iterate over the database in both of these cases. Where C and C differ is the place where the cursor carries out the iteration through the database. Whilst C carried out a single iteration every time it was invoked, the C and C 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 and C is B 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 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 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 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 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 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 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 in not. To delete a filter pass C 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 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 when writing, and C 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 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. Although B 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. =head1 HISTORY See the Changes file. =head1 AVAILABILITY The most recent version of B can always be found on CPAN (see L for details), in the directory F. The official web site for Berkeley DB is F. =head1 COPYRIGHT Copyright (c) 1997-2015 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 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) 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 Epmqs@cpan.orgE. =head1 SEE ALSO perl(1), DB_File, Berkeley DB. =cut BerkeleyDB-0.55/patches/0000755000175000017500000000000012472332224013527 5ustar paulpaulBerkeleyDB-0.55/patches/5.004_040000644000175000017500000001502607214774235014441 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.004_010000644000175000017500000001544007214774235014436 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.0050000644000175000017500000001600007214774235014130 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.004_050000644000175000017500000001507007214774235014441 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.0040000644000175000017500000000500107652524230014120 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.004_030000644000175000017500000001605407214774235014442 0ustar paulpauldiff -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 BerkeleyDB-0.55/patches/5.6.00000644000175000017500000002361007214774235014134 0ustar paulpauldiff -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 <>Makefile <{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 disables the appending of default ! libraries found in C<$Config{libs}> (this should be only needed very rarely). An entry that matches C 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 disables the appending of default ! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C disables all searching for the libraries specified after it. Translation of C<-Lfoo> and *************** *** 678,684 **** An entry that matches C 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 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 }; BerkeleyDB-0.55/patches/5.005_020000644000175000017500000002203007214774235014431 0ustar paulpauldiff -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 disables the appending of default ! libraries found in C<$Config{libs}> (this should be only needed very rarely). An entry that matches C 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 disables the appending of default ! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C disables all searching for the libraries specified after it. Translation of C<-Lfoo> and *************** *** 676,682 **** An entry that matches C 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 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 }; BerkeleyDB-0.55/patches/5.004_020000644000175000017500000001544007214774235014437 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.005_010000644000175000017500000001612407214774235014437 0ustar paulpauldiff -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 }; BerkeleyDB-0.55/patches/5.005_030000644000175000017500000002063207214774235014440 0ustar paulpauldiff -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 disables the appending of default ! libraries found in C<$Config{libs}> (this should be only needed very rarely). An entry that matches C 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 disables the appending of default ! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C disables all searching for the libraries specified after it. Translation of C<-Lfoo> and *************** *** 680,686 **** An entry that matches C 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 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) { BerkeleyDB-0.55/typemap0000644000175000017500000002403512141563546013514 0ustar paulpaul# typemap for Perl 5 interface to Berkeley DB version 2 & 3 # # SCCS: %I%, %G% # # written by Paul Marquess # #################################### 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_off_t T_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::DbStream 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::DbStream::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 DBT_Blob T_dbtdatum_blob DBTKEY T_dbtkeydatum DBTKEY_B T_dbtkeydatum_btree DBTKEY_B4Blob T_dbtkeydatum_btree_for_blob 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 BerkeleyDB__DbStream_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_for_blob { SV* my_sv = $arg ; if (! isHeapDb(db)) DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\"); DBT_clear($var) ; SvGETMAGIC($arg) ; STRLEN len; $var.data = SvPV(my_sv, len); $var.size = (int)len; } T_dbtdatum_blob { SV* my_sv = $arg ; DBT_clear($var) ; SvGETMAGIC($arg) ; STRLEN len; SvUPGRADE($arg, SVt_PV); SvOOK_off($arg); SvPOK_only($arg); $var.data = SvPVbyte_force(my_sv, len); $var.ulen = (int)len; $var.flags = DB_DBT_APPMALLOC | DB_DBT_USERMEM; } 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_for_blob OutputKeyBlob($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_blob 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); BerkeleyDB-0.55/t/0000755000175000017500000000000012472332224012343 5ustar paulpaulBerkeleyDB-0.55/t/examples.t.T0000644000175000017500000002042711150003670014545 0ustar paulpaul#!./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 } BerkeleyDB-0.55/t/txn.t0000644000175000017500000001576011063227133013347 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/recno.t0000644000175000017500000005260211731640155013645 0ustar paulpaul#!./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 ; } SKIP: if(0) { # RT #75691: scalar(@array) returns incorrect value after shift() on tied array skip "Test needs Berkeley DB 3.2 or better", 4 if $BerkeleyDB::db_version < 3.3; my $lex = new LexFile $Dfile ; my @array ; my $db ; ok $db = tie @array, 'BerkeleyDB::Recno', -Flags => DB_CREATE , -Filename => $Dfile ; isa_ok $db, 'BerkeleyDB::Recno'; $FA ? push @array, 7, 9, 11, 13 : $db->push(7, 9, 11, 13) ; is scalar(@array), 4; $FA ? shift @array : $db->shift() ; is scalar(@array), 3; undef $db; untie @array ; } __END__ # TODO # # DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records BerkeleyDB-0.55/t/blob.t0000644000175000017500000000775112141704204013452 0ustar paulpaul#!./perl -w use strict ; use lib 't'; use BerkeleyDB; use util ; use Test::More; plan(skip_all => "this needs Berkeley DB 6.x.x or better\n" ) if $BerkeleyDB::db_version < 6; plan tests => 84; my $Dfile = "dbhash.tmp"; my $Dfile2 = "dbhash2.tmp"; my $Dfile3 = "dbhash3.tmp"; unlink $Dfile; umask(0) ; sub isBlob { my $cursor = shift ; my $key = shift; my $v = ''; $cursor->partial_set(0,0) ; $cursor->c_get($key, $v, DB_SET) ; $cursor->partial_clear() ; return defined $cursor->db_stream(DB_STREAM_WRITE); } for my $TYPE ( qw(BerkeleyDB::Hash BerkeleyDB::Btree )) { #diag "Test $TYPE"; my $lex = new LexFile $Dfile ; my $home = "./fred" ; my $lexd = new LexDir $home ; my $threshold = 1234 ; ok my $env = new BerkeleyDB::Env Flags => DB_CREATE|DB_INIT_MPOOL, #@StdErrFile, BlobDir => $home, Home => $home ; ok my $db = new $TYPE Filename => $Dfile, Env => $env, BlobThreshold => $threshold, Flags => DB_CREATE ; isa_ok $db, $TYPE ; ok $env->get_blob_threshold(my $t1) == 0 ; is $t1, 0," env threshold is 0" ; ok $env->get_blob_dir(my $dir1) == 0 ; is $dir1, $home," env threshold is 0" ; ok $db->get_blob_threshold(my $t2) == 0 ; is $t2, $threshold," db threshold is $threshold" ; ok $db->get_blob_dir(my $dir2) == 0 ; is $dir2, $home, " env threshold is 0" ; my $smallData = "a234"; my $bigData = "x" x ($threshold+1) ; ok $db->db_put("1", $bigData) == 0 ; ok $db->db_put("2", $smallData) == 0 ; my $v2 ; ok $db->db_get("1", $v2) == 0 ; is $v2, $bigData; my $v1 ; ok $db->db_get("2", $v1) == 0 ; is $v1, $smallData; ok my $cursor = $db->db_cursor() ; ok isBlob($cursor, "1"); ok !isBlob($cursor, "2"); my $k = "1"; my $v = ''; $cursor->partial_set(0,0) ; ok $cursor->c_get($k, $v, DB_SET) == 0, "set cursor" or diag "Status is [" . $cursor->status() . "]"; $cursor->partial_clear() ; is $k, "1"; ok my $dbstream = $cursor->db_stream(DB_STREAM_WRITE) or diag "Status is [" . $cursor->status() . "]"; isa_ok $dbstream, 'BerkeleyDB::DbStream'; ok $dbstream->size(my $s) == 0 , "size"; is $s, length $bigData, "length ok"; my $new ; ok $dbstream->read($new, 0, length $bigData) == 0 , "read" or diag "Status is [" . $cursor->status() . "]"; is $new, $bigData; my $newData = "hello world" ; ok $dbstream->write($newData) == 0 , "write"; substr($bigData, 0, length($newData)) = $newData; my $new1; ok $dbstream->read($new, 0, 5) == 0 , "read"; is $new, "hello"; ok $dbstream->close() == 0 , "close"; $k = "1"; my $stream = $cursor->c_get_db_stream($k, DB_SET, DB_STREAM_WRITE) ; isa_ok $stream, 'BerkeleyDB::DbStream'; is $k, "1"; ok $stream->size($s) == 0 , "size"; is $s, length $bigData, "length ok"; $new = 'abc'; ok $stream->read($new, 0, 5) == 0 , "read"; is $new, "hello"; ok $stream->close() == 0 , "close"; ok my $cursor1 = $db->db_cursor() ; my $d1 ; my $d2 ; while (1) { my $k = ''; my $v = ''; $cursor->partial_set(0,0) ; my $status = $cursor1->c_get($k, $v, DB_NEXT) ; $cursor->partial_clear(); last if $status != 0 ; my $stream = $cursor1->db_stream(DB_STREAM_WRITE); if (defined $stream) { $stream->size(my $s) ; my $d = ''; my $delta = 1024; my $off = 0; while ($s) { $delta = $s if $s - $delta < 0 ; $stream->read($d, $off, $delta); $off += $delta ; $s -= $delta ; $d1 .= $d ; } } else { $cursor1->c_get($k, $d2, DB_CURRENT) ; } } is $d1, $bigData; is $d2, $smallData; } BerkeleyDB-0.55/t/unknown.t0000755000175000017500000001125511557013355014242 0ustar paulpaul#!./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 BerkeleyDB-0.55/t/subdb.t0000644000175000017500000001075711063227125013637 0ustar paulpaul#!./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 BerkeleyDB-0.55/t/hash.t0000644000175000017500000004375311545562414013475 0ustar paulpaul#!./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" ; } BerkeleyDB-0.55/t/db-4.6.t0000755000175000017500000001316111457134550013433 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/pod.t0000644000175000017500000000040410112106133013273 0ustar paulpauleval " 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(); BerkeleyDB-0.55/t/util.pm0000644000175000017500000001474411207314461013666 0ustar paulpaulpackage 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 = ; close(CAT); $result = normalise($result); return $result; } sub docat_del { my $file = shift; local $/ = undef; open(CAT,$file) || die "Cannot open $file: $!"; my $result = || "" ; 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 = ; @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 = ; 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; BerkeleyDB-0.55/t/examples3.t.T0000644000175000017500000000543411150003713014627 0ustar paulpaul#!./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 } BerkeleyDB-0.55/t/encrypt.t0000644000175000017500000004061211063227765014227 0ustar paulpaul#!./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; } BerkeleyDB-0.55/t/queue.t0000644000175000017500000005443011727151725013671 0ustar paulpaul#!./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 => 260; 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 ; } { # RT #75691: scalar(@array) returns incorrect value after shift() on tied array my $lex = new LexFile $Dfile ; my @array ; my $db ; $db = tie @array, 'BerkeleyDB::Queue', -Flags => DB_CREATE , -Len => 2, -Filename => $Dfile ; isa_ok $db, 'BerkeleyDB::Queue'; $FA ? push @array, "ab", "cd", "ef", "gh" : $db->push("ab", "cd", "ef", "gh") ; is scalar(@array), 4; $FA ? shift @array : $db->shift() ; is scalar(@array), 3; undef $db; untie @array ; } __END__ # TODO # # DB_DELIMETER DB_FIXEDLEN DB_PAD DB_SNAPSHOT with partial records BerkeleyDB-0.55/t/env.t0000644000175000017500000001547212472331147013334 0ustar paulpaul#!./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), "lexdir" ; 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, "no 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 BerkeleyDB-0.55/t/examples.t0000644000175000017500000002000112472332052014336 0ustar paulpaul#!./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 } BerkeleyDB-0.55/t/join.t0000644000175000017500000001370211063227062013470 0ustar paulpaul#!./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"; BerkeleyDB-0.55/t/db-4.3.t0000644000175000017500000000417211210525067013421 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/db-4.x.t0000755000175000017500000000171011063226765013535 0ustar paulpaul#!./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; BerkeleyDB-0.55/t/Test/0000755000175000017500000000000012472332224013262 5ustar paulpaulBerkeleyDB-0.55/t/Test/Builder.pm0000644000175000017500000011056111064022037015204 0ustar paulpaulpackage 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. =head2 Construction =over 4 =item B 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 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. =cut my $Test = Test::Builder->new; sub new { my($class) = shift; $Test ||= $class->create; return $Test; } =item B 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 if you're testing a Test::Builder based module, but otherwise you probably want C. B: the implementation is not complete. C, for example, is still shared amongst B 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 $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 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 $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 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 $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 $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (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 $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 $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(<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 $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $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 < $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 $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 $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 $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B 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 $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 < $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 < $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 $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 $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 $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 $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 $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 $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $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 $Test->diag(@msgs); Prints out the given @msgs. Like C, 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) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =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 $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $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 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 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
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 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 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 < _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 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 Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; BerkeleyDB-0.55/t/Test/More.pm0000644000175000017500000011136411064022146014523 0ustar paulpaulpackage 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 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 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 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: using no_plan requires a Test::Harness upgrade else it will think everything has failed. See L) 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 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($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 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 =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C 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 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 function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. 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) 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( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike ($$;$) { $Test->unlike(@_); } =item B 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 will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B 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($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 <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 =item B 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. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Like C @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 with the mnemonic C. All diag()s can be made silent by passing the "no_diag" option to Test::More. C 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 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 and C. =over 4 =item B 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 <ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $Test->diag(< 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 <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. 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: { 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. 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 $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, 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: { 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: TODO tests require a Test::Harness upgrade else it will treat it as a normal failure. See L) =item B 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 with and using C. 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 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, 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, 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 I'm not quite sure what will happen with filehandles. =over 4 =item B 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 = <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 can do that better and with diagnostics. is_deeply( \@this, \@that ); They may be deprecated in future versions. =over 4 =item B 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 < 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 my $is_eq = eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B 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 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. 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 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 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. 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 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 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 is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L for more ways to test complex data structures. And it plays well with Test::More. L is like XUnit but more perlish. L gives you more powerful complex data structure testing. L is XUnit style testing. L shows the idea of embedded testing. L installs a whole bunch of useful test modules. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE 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 to report and view bugs. =head1 COPYRIGHT Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; BerkeleyDB-0.55/t/db-4.4.t0000644000175000017500000000200011063226754013415 0ustar paulpaul#!./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"; } BerkeleyDB-0.55/t/examples3.t0000644000175000017500000000532412472332052014434 0ustar paulpaul#!./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 } BerkeleyDB-0.55/t/heap.t0000644000175000017500000003306011577221201013444 0ustar paulpaul#!./perl -w use strict ; use lib 't'; use BerkeleyDB; use util ; use Test::More; plan(skip_all => "Heap needs Berkeley DB 5.2.x or better\n" ) if $BerkeleyDB::db_version < 5.2; # TODO - fix this plan(skip_all => "Heap suport not available\n" ) if ! BerkeleyDB::has_heap() ; plan tests => 68; 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::Heap -Stupid => 3 ; ' ; ok $@ =~ /unknown key value\(s\) Stupid/ ; eval ' $db = new BerkeleyDB::Heap -Bad => 2, -Mode => 0345, -Stupid => 3; ' ; ok $@ =~ /unknown key value\(s\) (Bad,? |Stupid,? ){2}/ or print "# $@" ; eval ' $db = new BerkeleyDB::Heap -Env => 2 ' ; ok $@ =~ /^Env not of type BerkeleyDB::Env/ ; eval ' $db = new BerkeleyDB::Heap -Txn => "x" ' ; ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ; my $obj = bless [], "main" ; eval ' $db = new BerkeleyDB::Heap -Env => $obj ' ; ok $@ =~ /^Env not of type BerkeleyDB::Env/ ; } { # Tied Hash interface my $lex = new LexFile $Dfile ; my %hash ; eval " tie %hash, 'BerkeleyDB::Heap', -Filename => '$Dfile', -Flags => DB_CREATE ; " ; ok $@ =~ /^Tied Hash interface not supported with BerkeleyDB::Heap/; } # Now check the interface to Heap { my $lex = new LexFile $Dfile ; ok my $db = new BerkeleyDB::Heap -Filename => $Dfile, -Flags => DB_CREATE or diag "Cannot create Heap: [$!][$BerkeleyDB::Error]\n" ; # Add a k/v pair my $value ; my $status ; my $key1; my $key2; is $db->Env, undef; ok $db->db_put($key1, "some value", DB_APPEND) == 0 or diag "Cannot db_put: " . $db->status() . "[$!][$BerkeleyDB::Error]\n" ; ok $db->status() == 0 ; ok $db->db_get($key1, $value) == 0 or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ; ok $value eq "some value" ; ok $db->db_put($key2, "value", DB_APPEND) == 0 ; ok $db->db_get($key2, $value) == 0 or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ; ok $value eq "value" ; ok $db->db_del($key1) == 0 ; ok $db->db_get($key1, $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( $key2, '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($key2, $value) == 0 ; ok $value eq "value" ; # test DB_GET_BOTH my ($k, $v) = ($key2, "value") ; ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ; ($k, $v) = ($key2, "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::Heap -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 $key ; my $value ; ok $db->db_put($key, "some value", DB_APPEND) == 0 ; ok $db->db_get($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::Heap -Filename => $Dfile, -Flags => DB_CREATE ; #print "[$db] [$!] $BerkeleyDB::Error\n" ; # create some data my %data = (); my %keys = (); my $ret = 0 ; for my $v (qw(2 house sea)){ my $key; $ret += $db->db_put($key, $v, DB_APPEND) ; $data{$key} = $v; $keys{$v} = $key; } 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, "extras == 0" ; ($k, $v) = ($keys{"house"}, "house") ; ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0, "c_get BOTH" ; ($k, $v) = ($keys{"house"}, "door") ; ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ; ($k, $v) = ("black", "house") ; ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ; } { # in-memory file my $lex = new LexFile $Dfile ; my %hash ; my $fd ; my $value ; #ok my $db = tie %hash, 'BerkeleyDB::Heap' ; my $db = new BerkeleyDB::Heap -Flags => DB_CREATE ; isa_ok $db, 'BerkeleyDB::Heap' ; my $key; ok $db->db_put($key, "some value", DB_APPEND) == 0 ; ok $db->db_get($key, $value) == 0 ; ok $value eq "some value", "some value" ; } if (0) { # partial # check works via API my $lex = new LexFile $Dfile ; my $value ; ok my $db = new BerkeleyDB::Heap -Filename => $Dfile, -Flags => DB_CREATE ; # create some data my $red; my $green; my $blue; my %data = ( "red" => "boat", "green" => "house", "blue" => "sea", ) ; my %keys = ( "red" => \$red, "green" => \$green, "blue" => \$blue, ) ; my $ret = 0 ; while (my ($k, $v) = each %data) { my $key; $ret += $db->db_put($key, $v, DB_APPEND) ; ${ $keys{$k} } = $key; } ok $ret == 0, "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, "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, "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 my $new; $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", DB_APPEND) == 0 ; ($pon, $off, $len) = $db->partial_clear() ; ok $pon ; ok $off == 0 ; ok $len == 2, "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, "Q" ; ok $db->db_put($blue, "XYZ") == 0, "XYZ" ; # <<<<<<<<<<<<<< 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", "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 = new BerkeleyDB::Heap -Filename => $Dfile, -Flags => DB_CREATE , -Env => $env, -Txn => $txn ; 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) { my $key; $ret += $db1->db_put($key, $v, DB_APPEND) ; } 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 ; } exit; { # DB_DUP my $lex = new LexFile $Dfile ; my %hash ; ok my $db = tie %hash, 'BerkeleyDB::Heap', -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::Heap -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::Heap ); @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" ; } BerkeleyDB-0.55/t/db-3.2.t0000644000175000017500000000200411063226740013411 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/cds.t0000644000175000017500000000253511063226720013304 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/filter.t0000644000175000017500000002044511156745754014040 0ustar paulpaul#!./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; } BerkeleyDB-0.55/t/db-4.8.t0000644000175000017500000001736711557055545013455 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/db-4.7.t0000644000175000017500000000134711070515334013426 0ustar paulpaul#!./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 BerkeleyDB-0.55/t/mldbm.t0000644000175000017500000000435711063564353013641 0ustar paulpaul#!/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 ; } BerkeleyDB-0.55/t/sequence.t0000755000175000017500000000220411064022433014333 0ustar paulpaul 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"; } BerkeleyDB-0.55/t/destroy.t0000644000175000017500000000404311063226775014232 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/db-3.0.t0000644000175000017500000000302511063226725013416 0ustar paulpaul#!./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" ; } BerkeleyDB-0.55/t/btree.t0000644000175000017500000005516712130034326013640 0ustar paulpaul#!./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 ; } is_deeply [keys %h], \@srt_1 ; is_deeply [keys %g], \@srt_2 ; is_deeply [keys %k], \@srt_3 ; } { # 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 ; } is_deeply [keys %h], \@srt_1 ; is_deeply [keys %g], \@srt_2 ; is_deeply [keys %k], \@srt_3 ; is_deeply [getValues \%h], [qw(dd 0 0 x 3 1 abc)]; is_deeply [getValues \%g], [qw(dd 1 3 0 x abc 0)] or diag "Expected [dd 1 0 3 x abc 0] got [@{ [getValues(\%g)] }]\n"; is_deeply [getValues \%k], [qw(0 x 3 0 1 dd abc)]; # 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 ; } is_deeply [keys %h], \@srt_1 ; is_deeply [keys %g], \@srt_2 ; is_deeply [getValues \%h], [qw(dd 0 11 2 x 3 1 abc)]; is_deeply [getValues \%h], [qw(dd 0 11 2 x 3 1 abc)]; } { # 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 ; } BerkeleyDB-0.55/t/db-3.3.t0000644000175000017500000002537711456535324013443 0ustar paulpaul#!./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 ; } BerkeleyDB-0.55/t/strict.t0000644000175000017500000001220711063227121014034 0ustar paulpaul#!./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" ; } BerkeleyDB-0.55/t/encode.t0000644000175000017500000000244511156753471014003 0ustar paulpaul#!./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; } BerkeleyDB-0.55/t/db-3.1.t0000644000175000017500000001340611063226732013421 0ustar paulpaul#!./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 BerkeleyDB-0.55/dbinfo0000755000175000017500000000645511550341114013273 0ustar paulpaul#!/usr/local/bin/perl # Name: dbinfo -- identify berkeley DB version used to create # a database file # # Author: Paul Marquess # 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 <{Type} file. File Version ID: $version Built with Berkeley DB: $ver_string Byte Order: $endian Magic: $magic Encryption: $encrypt EOM close F ; exit ; BerkeleyDB-0.55/META.json0000644000175000017500000000152512472332224013524 0ustar paulpaul{ "abstract" : "Perl extension for Berkeley DB version 2, 3, 4 or 5", "author" : [ "Paul Marquess " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "BerkeleyDB", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "0.55" } BerkeleyDB-0.55/META.yml0000644000175000017500000000076512472332224013361 0ustar paulpaul--- abstract: 'Perl extension for Berkeley DB version 2, 3, 4 or 5' author: - 'Paul Marquess ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: BerkeleyDB no_index: directory: - t - inc requires: {} version: '0.55' BerkeleyDB-0.55/mkconsts.pl0000755000175000017500000011170112316005411014272 0ustar paulpaul#!/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.15 ######### 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_CHKSUM_FAIL => DEFINE, DB_INTERNAL_PERSISTENT_DB => DEFINE, DB_INTERNAL_TEMPORARY_DB => DEFINE, DB_LOCK_IGNORE_REC => DEFINE, DB_VERB_BACKUP => DEFINE, MP_FOR_FLUSH => IGNORE, # enum DB_BACKUP_CONFIG DB_BACKUP_READ_COUNT => '5.3.15', DB_BACKUP_READ_SLEEP => '5.3.15', DB_BACKUP_SIZE => '5.3.15', DB_BACKUP_WRITE_DIRECT => '5.3.15', ######### # 6.0.19 ######### DB_DBT_BLOB => IGNORE, DB_DBT_BLOB_REC => IGNORE, DB_EVENT_REP_AUTOTAKEOVER_FAILED => DEFINE, DB_INTERNAL_BLOB_DB => DEFINE, DB_LOG_BLOB => DEFINE, DB_REPMGR_ISVIEW => DEFINE, DB_STREAM_READ => DEFINE, DB_STREAM_SYNC_WRITE => DEFINE, DB_STREAM_WRITE => DEFINE, DB_VERB_MVCC => DEFINE, ######### # 6.0.30 ######### # enum log_rec_type_t LOGREC_LONGARG => '6.0.30', ######### # 6.1.10 ######### DB_EVENT_FAILCHK_PANIC => DEFINE, DB_EVENT_MUTEX_DIED => DEFINE, DB_EVENT_REP_INQUEUE_FULL => DEFINE, DB_EXIT_FAILCHK => DEFINE, DB_EXIT_FILE_EXISTS => DEFINE, DB_FAILURE_SYMPTOM_SIZE => DEFINE, DB_LOG_NOSYNC => DEFINE, DB_MUTEX_DESCRIBE_STRLEN => DEFINE, DB_MUTEX_OWNER_DEAD => DEFINE, DB_REPMGR_CONF_PREFMAS_CLIENT => DEFINE, DB_REPMGR_CONF_PREFMAS_MASTER => DEFINE, DB_REP_CONF_ELECT_LOGLENGTH => DEFINE, DB_SET_MUTEX_FAILCHK_TIMEOUT => DEFINE, ) ; 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 () { if ( /^\s*$START_re/ ) { # skip to the end marker. while () { 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 () { 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() ; BerkeleyDB-0.55/constants.xs0000644000175000017500000000502012471374215014472 0ustar paulpaulvoid 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); } BerkeleyDB-0.55/mkpod0000755000175000017500000000574006756034737013166 0ustar paulpaul#!/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 () { # 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 = ) { 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 = ) { 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 ; } BerkeleyDB-0.55/Todo0000644000175000017500000000265407023545755012752 0ustar paulpaul * 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()