BerkeleyDB-0.64/0000755000175000017500000000000013730620756012110 5ustar paulpaulBerkeleyDB-0.64/MANIFEST0000644000175000017500000000205713514656514013246 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/000prereq.t 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/meta-json.t t/meta-yaml.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.64/constants.h0000644000175000017500000070102313426367042014276 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 SELECT */ /* 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 'E': if (memEQ(name, "SELECT", 6)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = SELECT; 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 >= 10) *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_SLICED 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 >= 21) *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 } if (memEQ(name, "DB_SLICED", 9)) { /* ^ */ #ifdef DB_SLICED *iv_return = DB_SLICED; 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 >= 21) *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_CONVERT 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_NOINTMP 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 HAVE_EPOLL 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 >= 21) *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 >= 21) *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 'L': if (memEQ(name, "HAVE_EPOLL", 10)) { /* ^ */ #ifdef HAVE_EPOLL *iv_return = HAVE_EPOLL; 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 } if (memEQ(name, "DB_NOINTMP", 10)) { /* ^ */ #ifdef DB_NOINTMP *iv_return = DB_NOINTMP; 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_CONVERT", 10)) { /* ^ */ #ifdef DB_CONVERT *iv_return = DB_CONVERT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } 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 >= 21) *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 >= 21) *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 >= 21) *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 >= 21) *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 >= 10) *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 >= 21) *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_OFF_T_MAX 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 >= 10) *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_OFF_T_MAX", 12)) { /* ^ */ #ifdef DB_OFF_T_MAX *iv_return = DB_OFF_T_MAX; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } 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 >= 21) *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 >= 21) *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_VERB_SLICE 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 >= 21) *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 >= 21) *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 >= 10) *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 >= 10) *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_VERB_SLICE", 13)) { /* ^ */ #ifdef DB_VERB_SLICE *iv_return = DB_VERB_SLICE; 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_INELECT 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 } if (memEQ(name, "DB_REP_INELECT", 14)) { /* ^ */ #ifdef DB_REP_INELECT *iv_return = DB_REP_INELECT; 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 >= 21) *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_FORCESYNCENV 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_EXT_FILE DB_LOG_INMEMORY DB_LOG_WRNOSYNC DB_MEM_DATABASE DB_MEM_REP_SITE 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_DISPATCH 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 'A': if (memEQ(name, "DB_MEM_DATABASE", 15)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = DB_MEM_DATABASE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; 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_FORCESYNCENV", 15)) { /* ^ */ #ifdef DB_FORCESYNCENV *iv_return = DB_FORCESYNCENV; 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_DISPATCH", 15)) { /* ^ */ #ifdef DB_TXN_DISPATCH *iv_return = DB_TXN_DISPATCH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } 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_LOG_EXT_FILE", 15)) { /* ^ */ #ifdef DB_LOG_EXT_FILE *iv_return = DB_LOG_EXT_FILE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DB_MEM_REP_SITE", 15)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = DB_MEM_REP_SITE; 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_SLICE_CORRUPT 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 } if (memEQ(name, "DB_SLICE_CORRUPT", 16)) { /* ^ */ #ifdef DB_SLICE_CORRUPT *iv_return = DB_SLICE_CORRUPT; 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 >= 10) *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 >= 21) *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 >= 10) *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. DB2_AM_MPOOL_OPENED 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_META_CHKSUM_FAIL 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 'U': if (memEQ(name, "DB_META_CHKSUM_FAIL", 19)) { /* ^ */ #ifdef DB_META_CHKSUM_FAIL *iv_return = DB_META_CHKSUM_FAIL; 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, "DB2_AM_MPOOL_OPENED", 19)) { /* ^ */ #ifdef DB2_AM_MPOOL_OPENED *iv_return = DB2_AM_MPOOL_OPENED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } 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_REPMGR_ISELECTABLE DB_REP_ELECTION_RETRY DB_REP_HEARTBEAT_SEND DB_SYSTEM_MEM_MISSING */ /* Offset 15 gives the best switch position. */ switch (name[15]) { case 'A': 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 } 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 } break; case 'C': if (memEQ(name, "DB_REPMGR_ISELECTABLE", 21)) { /* ^ */ #ifdef DB_REPMGR_ISELECTABLE *iv_return = DB_REPMGR_ISELECTABLE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': 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 'F': 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 'H': 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 'I': if (memEQ(name, "DB_SYSTEM_MEM_MISSING", 21)) { /* ^ */ #ifdef DB_SYSTEM_MEM_MISSING *iv_return = DB_SYSTEM_MEM_MISSING; 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 'O': 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; case 'Q': 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_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 'S': 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 } break; case 'T': 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 'Y': 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 '_': 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 } 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; } 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_MEM_DATABASE_LENGTH 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_MEM_DATABASE_LENGTH", 22)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = DB_MEM_DATABASE_LENGTH; 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_MEM_EXTFILE_DATABASE DB_REGION_MAGIC_RECOVER 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 11 gives the best switch position. */ switch (name[11]) { case 'A': if (memEQ(name, "DB_REGION_MAGIC_RECOVER", 23)) { /* ^ */ #ifdef DB_REGION_MAGIC_RECOVER *iv_return = DB_REGION_MAGIC_RECOVER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': 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_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 '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 } 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 'I': if (memEQ(name, "DB_MEM_EXTFILE_DATABASE", 23)) { /* ^ */ #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = DB_MEM_EXTFILE_DATABASE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': 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 'M': 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 'P': 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; case 'S': 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 'T': 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 'U': 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 'W': if (memEQ(name, "DB_ENV_TXN_WRITE_NOSYNC", 23)) { /* ^ */ #ifdef DB_ENV_TXN_WRITE_NOSYNC *iv_return = DB_ENV_TXN_WRITE_NOSYNC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '_': if (memEQ(name, "DB_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; } 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_AUTOTAKEOVER 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 13 gives the best switch position. */ switch (name[13]) { case 'A': if (memEQ(name, "DB_EVENT_REP_AUTOTAKEOVER", 25)) { /* ^ */ #ifdef DB_EVENT_REP_AUTOTAKEOVER *iv_return = DB_EVENT_REP_AUTOTAKEOVER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'C': 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 'E': 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 'I': 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 'J': 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 'S': 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_REPMGR_CONF_DISABLE_POLL DB_REPMGR_CONF_ENABLE_EPOLL DB_REP_CONF_ELECT_LOGLENGTH */ /* Offset 19 gives the best switch position. */ switch (name[19]) { case 'B': if (memEQ(name, "DB_REPMGR_CONF_DISABLE_POLL", 27)) { /* ^ */ #ifdef DB_REPMGR_CONF_DISABLE_POLL *iv_return = DB_REPMGR_CONF_DISABLE_POLL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': if (memEQ(name, "DB_REPMGR_CONF_2SITE_STRICT", 27)) { /* ^ */ #ifdef DB_REPMGR_CONF_2SITE_STRICT *iv_return = DB_REPMGR_CONF_2SITE_STRICT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "DB_REPMGR_CONF_ENABLE_EPOLL", 27)) { /* ^ */ #ifdef DB_REPMGR_CONF_ENABLE_EPOLL *iv_return = DB_REPMGR_CONF_ENABLE_EPOLL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'O': if (memEQ(name, "DB_REP_CONF_ELECT_LOGLENGTH", 27)) { /* ^ */ #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 'R': if (memEQ(name, "DB_EVENT_REP_WOULD_ROLLBACK", 27)) { /* ^ */ #ifdef DB_EVENT_REP_WOULD_ROLLBACK *iv_return = DB_EVENT_REP_WOULD_ROLLBACK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DB_EVENT_REP_CONNECT_BROKEN", 27)) { /* ^ */ #ifdef DB_EVENT_REP_CONNECT_BROKEN *iv_return = DB_EVENT_REP_CONNECT_BROKEN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '_': if (memEQ(name, "DB_EVENT_REP_MASTER_FAILURE", 27)) { /* ^ */ #ifdef DB_EVENT_REP_MASTER_FAILURE *iv_return = DB_EVENT_REP_MASTER_FAILURE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_28 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. DB_EVENT_REP_ELECTION_FAILED DB_REPMGR_ACKS_ALL_AVAILABLE DB_REP_FULL_ELECTION_TIMEOUT DB_REP_WRITE_FORWARD_TIMEOUT DB_SET_MUTEX_FAILCHK_TIMEOUT */ /* Offset 19 gives the best switch position. */ switch (name[19]) { 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 'D': if (memEQ(name, "DB_REP_WRITE_FORWARD_TIMEOUT", 28)) { /* ^ */ #ifdef DB_REP_WRITE_FORWARD_TIMEOUT *iv_return = DB_REP_WRITE_FORWARD_TIMEOUT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': 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; case 'N': 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 'O': if (memEQ(name, "DB_EVENT_REP_ELECTION_FAILED", 28)) { /* ^ */ #ifdef DB_EVENT_REP_ELECTION_FAILED *iv_return = DB_EVENT_REP_ELECTION_FAILED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_29 (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_REPMGR_CONF_FORWARD_WRITES 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 'S': if (memEQ(name, "DB_REPMGR_CONF_FORWARD_WRITE", 28)) { /* S */ #ifdef DB_REPMGR_CONF_FORWARD_WRITES *iv_return = DB_REPMGR_CONF_FORWARD_WRITES; 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; } 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 #!/media/paul/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_MPOOL_OPENED 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_CONVERT 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 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_FORCESYNCENV 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_EXT_FILE 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_META_CHKSUM_FAIL 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_NOINTMP 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_OFF_T_MAX 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_MAGIC_RECOVER 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_DISABLE_POLL DB_REPMGR_CONF_ELECTIONS DB_REPMGR_CONF_ENABLE_EPOLL DB_REPMGR_CONF_FORWARD_WRITES DB_REPMGR_CONF_PREFMAS_CLIENT DB_REPMGR_CONF_PREFMAS_MASTER DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISELECTABLE 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_INELECT 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_REP_WRITE_FORWARD_TIMEOUT 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_SLICED DB_SLICE_CORRUPT 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_SYSTEM_MEM_MISSING 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_DISPATCH 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_SLICE 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 HAVE_EPOLL), {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 >= 10)\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_DATABASE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\n", "#endif\n"]}, {name=>"DB_MEM_DATABASE_LENGTH", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\n", "#endif\n"]}, {name=>"DB_MEM_EXTFILE_DATABASE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\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 >= 10)\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 >= 10)\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 >= 10)\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 >= 10)\n", "#endif\n"]}, {name=>"DB_MEM_REP_SITE", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\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 >= 10)\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 >= 10)\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 >= 21)\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=>"EPOLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\n", "#endif\n"]}, {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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\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 >= 21)\n", "#endif\n"]}, {name=>"POLL", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\n", "#endif\n"]}, {name=>"SELECT", type=>"IV", macro=>["#if (DB_VERSION_MAJOR > 6) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \\\n (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \\\n DB_VERSION_PATCH >= 10)\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 4: if (memEQ(name, "POLL", 4)) { #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = POLL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 5: if (memEQ(name, "EPOLL", 5)) { #if (DB_VERSION_MAJOR > 6) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR > 3) || \ (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR == 3 && \ DB_VERSION_PATCH >= 10) *iv_return = EPOLL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 6: return constant_6 (aTHX_ name, iv_return); break; case 7: return constant_7 (aTHX_ name, iv_return); break; case 8: return constant_8 (aTHX_ name, iv_return); break; case 9: return constant_9 (aTHX_ name, iv_return); break; case 10: return constant_10 (aTHX_ name, iv_return); break; case 11: return constant_11 (aTHX_ name, iv_return); break; case 12: 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: return constant_29 (aTHX_ name, iv_return); break; case 31: /* Names all of length 31. */ /* DB_EVENT_REP_CONNECT_TRY_FAILED DB_EVENT_REP_LOCAL_SITE_REMOVED */ /* Offset 19 gives the best switch position. */ switch (name[19]) { case 'S': if (memEQ(name, "DB_EVENT_REP_LOCAL_SITE_REMOVED", 31)) { /* ^ */ #ifdef DB_EVENT_REP_LOCAL_SITE_REMOVED *iv_return = DB_EVENT_REP_LOCAL_SITE_REMOVED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DB_EVENT_REP_CONNECT_TRY_FAILED", 31)) { /* ^ */ #ifdef DB_EVENT_REP_CONNECT_TRY_FAILED *iv_return = DB_EVENT_REP_CONNECT_TRY_FAILED; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; 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.64/BerkeleyDB.pm0000644000175000017500000012413313730616201014410 0ustar paulpaul package BerkeleyDB; # Copyright (c) 1997-2020 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.64'; 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_MPOOL_OPENED 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_CONVERT 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 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_FORCESYNCENV 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_EXT_FILE 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_DATABASE DB_MEM_DATABASE_LENGTH DB_MEM_EXTFILE_DATABASE DB_MEM_LOCK DB_MEM_LOCKER DB_MEM_LOCKOBJECT DB_MEM_LOGID DB_MEM_REP_SITE DB_MEM_THREAD DB_MEM_TRANSACTION DB_META_CHKSUM_FAIL 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_NOINTMP 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_OFF_T_MAX 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_MAGIC_RECOVER 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_DISABLE_POLL DB_REPMGR_CONF_ELECTIONS DB_REPMGR_CONF_ENABLE_EPOLL DB_REPMGR_CONF_FORWARD_WRITES DB_REPMGR_CONF_PREFMAS_CLIENT DB_REPMGR_CONF_PREFMAS_MASTER DB_REPMGR_CONNECTED DB_REPMGR_DISCONNECTED DB_REPMGR_ISELECTABLE 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_INELECT 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_REP_WRITE_FORWARD_TIMEOUT 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_SLICED DB_SLICE_CORRUPT 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_SYSTEM_MEM_MISSING 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_DISPATCH 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_SLICE 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 EPOLL HAVE_EPOLL 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 POLL SELECT ); 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, LogFileMode => undef, 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.64/README0000755000175000017500000006010213730612640012763 0ustar paulpaul BerkeleyDB Version 0.64 17th August 2020 Copyright (c) 1997-2020 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.64/ppport.h0000644000175000017500000065716513517260755013633 0ustar paulpaul#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.52 Automatically created by Devel::PPPort running under perl 5.024000. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.52 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.30. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagically add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL SvRX() NEED_SvRX NEED_SvRX_GLOBAL caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL croak_xs_usage() NEED_croak_xs_usage NEED_croak_xs_usage_GLOBAL die_sv() NEED_die_sv NEED_die_sv_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL mess() NEED_mess NEED_mess_GLOBAL mess_nocontext() NEED_mess_nocontext NEED_mess_nocontext_GLOBAL mess_sv() NEED_mess_sv NEED_mess_sv_GLOBAL mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL my_strnlen() NEED_my_strnlen NEED_my_strnlen_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL utf8_to_uvchr_buf() NEED_utf8_to_uvchr_buf NEED_utf8_to_uvchr_buf_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vmess() NEED_vmess NEED_vmess_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please send a bug report to L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= 5.009004 && "$]" <= 5.009005 } my $VERSION = 3.52; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| BOM_UTF8||| BhkDISABLE||5.024000| BhkENABLE||5.024000| BhkENTRY_set||5.024000| BhkENTRY||| BhkFLAGS||| CALL_BLOCK_HOOKS||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| C_ARRAY_END|5.013002||p C_ARRAY_LENGTH|5.008001||p CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002|5.004050|p Copy||| CvPADLIST||5.008001| CvSTASH||| CvWEAKOUTSIDE||| DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n DEFSV_set|5.010001||p DEFSV|5.004050||p DO_UTF8||5.006000| END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvAV||| GvCV||| GvHV||| GvSV||| Gv_AMupdate||5.011000| HEf_SVKEY|5.003070||p HeHASH||5.003070| HeKEY||5.003070| HeKLEN||5.003070| HePV||5.004000| HeSVKEY_force||5.003070| HeSVKEY_set||5.004000| HeSVKEY||5.003070| HeUTF8|5.010001|5.008000|p HeVAL||5.003070| HvENAMELEN||5.015004| HvENAMEUTF8||5.015004| HvENAME||5.013007| HvNAMELEN_get|5.009003||p HvNAMELEN||5.015004| HvNAMEUTF8||5.015004| HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LIKELY|||p LINKLIST||5.013006| LVRET||| MARK||| MULTICALL||5.024000| MUTABLE_PTR|5.010001||p MUTABLE_SV|5.010001||p MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002|5.004050|p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| OP_CLASS||5.013007| OP_DESC||5.007003| OP_NAME||5.007003| OP_TYPE_IS_OR_WAS||5.019010| OP_TYPE_IS||5.019007| ORIGMARK||| OpHAS_SIBLING|5.021007||p OpLASTSIB_set|5.021011||p OpMAYBESIB_set|5.021011||p OpMORESIB_set|5.021011||p OpSIBLING|5.021007||p PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_ARGS_ASSERT_CROAK_XS_USAGE|||p PERL_BCDVERSION|5.024000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.003070||p PERL_INT_MAX|5.003070||p PERL_INT_MIN|5.003070||p PERL_LONG_MAX|5.003070||p PERL_LONG_MIN|5.003070||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.024000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.024000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.024000||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.024000||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.003070||p PERL_QUAD_MIN|5.003070||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.003070||p PERL_SHORT_MIN|5.003070||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.024000| PERL_UCHAR_MAX|5.003070||p PERL_UCHAR_MIN|5.003070||p PERL_UINT_MAX|5.003070||p PERL_UINT_MIN|5.003070||p PERL_ULONG_MAX|5.003070||p PERL_ULONG_MIN|5.003070||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_RESULT|5.021001||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.003070||p PERL_UQUAD_MIN|5.003070||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.003070||p PERL_USHORT_MIN|5.003070||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.024000||p PL_bufptr|5.024000||p PL_check||5.006000| PL_compiling|5.004050||p PL_comppad_name||5.017004| PL_comppad||5.008001| PL_copline|5.024000||p PL_curcop|5.004050||p PL_curpad||5.005000| PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.024000||p PL_expect|5.024000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.024000||p PL_in_my|5.024000||p PL_keyword_plugin||5.011002| PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.024000||p PL_lex_stuff|5.024000||p PL_linestr|5.024000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_opfreehook||5.011000|n PL_parser|5.009005||p PL_peepp||5.007003|n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rpeepp||5.013005|n PL_rsfp_filters|5.024000||p PL_rsfp|5.024000||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_sv_zero|||n PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.024000||p POP_MULTICALL||5.024000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n POPul||5.006000|n POPu||5.004000|n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.024000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PadARRAY||5.024000| PadMAX||5.024000| PadlistARRAY||5.024000| PadlistMAX||5.024000| PadlistNAMESARRAY||5.024000| PadlistNAMESMAX||5.024000| PadlistNAMES||5.024000| PadlistREFCNT||5.017004| PadnameIsOUR||| PadnameIsSTATE||| PadnameLEN||5.024000| PadnameOURSTASH||| PadnameOUTER||| PadnamePV||5.024000| PadnameREFCNT_dec||5.024000| PadnameREFCNT||5.024000| PadnameSV||5.024000| PadnameTYPE||| PadnameUTF8||5.021007| PadnamelistARRAY||5.024000| PadnamelistMAX||5.024000| PadnamelistREFCNT_dec||5.024000| PadnamelistREFCNT||5.024000| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_restore_errno||| PerlIO_save_errno||| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| PerlLIO_dup2_cloexec||| PerlLIO_dup_cloexec||| PerlLIO_open3_cloexec||| PerlLIO_open_cloexec||| PerlProc_pipe_cloexec||| PerlSock_accept_cloexec||| PerlSock_socket_cloexec||| PerlSock_socketpair_cloexec||| Perl_langinfo|||n Perl_setlocale|||n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p READ_XDIGIT||5.017006| REPLACEMENT_CHARACTER_UTF8||| RESTORE_LC_NUMERIC||5.024000| RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STORE_LC_NUMERIC_FORCE_TO_UNDERLYING||5.024000| STORE_LC_NUMERIC_SET_TO_NEEDED||5.024000| STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_INVLIST||5.019002| SVt_IV||| SVt_NULL||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVFM||| SVt_PVGV||| SVt_PVHV||| SVt_PVIO||| SVt_PVIV||| SVt_PVLV||| SVt_PVMG||| SVt_PVNV||| SVt_PV||| SVt_REGEXP||5.011000| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_ro||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_nomg||5.013002| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVCLEAR||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg_nolen|5.013007||p SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREADONLY_off||| SvREADONLY_on||| SvREADONLY||| SvREFCNT_dec_NN||5.017007| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK|5.009005||p SvRX|5.009005||p SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTHINKFIRST||| SvTRUE_nomg||5.013006| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UNICODE_REPLACEMENT|||p UNLIKELY|||p UTF8SKIP||5.006000| UTF8_IS_INVARIANT||| UTF8_IS_NONCHAR||| UTF8_IS_SUPER||| UTF8_IS_SURROGATE||| UTF8_MAXBYTES|5.009002||p UTF8_SAFE_SKIP|||p UVCHR_IS_INVARIANT||| UVCHR_SKIP||5.022000| UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.024000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p WIDEST_UTYPE|5.015004||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_APIVERSION_BOOTCHECK||5.024000| XS_EXTERNAL||5.024000| XS_INTERNAL||5.024000| XS_VERSION_BOOTCHECK||5.024000| XS_VERSION||| XSprePUSH|5.006000||p XS||| XopDISABLE||5.024000| XopENABLE||5.024000| XopENTRYCUSTOM||5.024000| XopENTRY_set||5.024000| XopENTRY||5.024000| XopFLAGS||5.013007| ZeroD|5.009002||p Zero||| __ASSERT_|||p _aMY_CXT|5.007003||p _inverse_folds||| _is_grapheme||| _is_in_locale_category||| _new_invlist_C_array||| _pMY_CXT|5.007003||p _to_fold_latin1|||n _to_upper_title_latin1||| _to_utf8_case||| _variant_byte_number|||n _warn_problematic_locale|||n aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.024000||p aTHXR|5.024000||p aTHX_|5.006000||p aTHX|5.006000||p abort_execution||| add_above_Latin1_folds||| add_data|||n add_multi_match||| add_utf16_textfilter||| adjust_size_and_find_bucket|||n advance_one_LB||| advance_one_SB||| advance_one_WB||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_deref_call||5.013007| amagic_i_ncmp||| amagic_is_enabled||| amagic_ncmp||| anonymise_cv_maybe||| any_dup||| ao||| apply_attrs_my||| apply_attrs||| apply||| argvout_final||| assert_uft8_cache_coherent||| assignment_type||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_delete||5.006000| av_exists||5.006000| av_extend_guts||| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_nonelem||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_tindex|5.017009|5.017009|p av_top_index|5.017009|5.017009|p av_undef||| av_unshift||| ax|||n backup_one_GCB||| backup_one_LB||| backup_one_SB||| backup_one_WB||| bad_type_gv||| bad_type_pv||| bind_match||| block_end||5.004000| block_gimme||5.004000| block_start||5.004000| blockhook_register||5.013003| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_cmp_utf8||5.013007| cBOOL|5.013000||p call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p caller_cx|5.013005|5.006000|p calloc||5.007002|n cando||| cast_i32||5.006000|n cast_iv||5.006000|n cast_ulong||5.006000|n cast_uv||5.006000|n category_name|||n change_engine_size||| check_and_deprecate||| check_type_and_open||| check_uni||| checkcomma||| ckWARN2_d||| ckWARN2||| ckWARN3_d||| ckWARN3||| ckWARN4_d||| ckWARN4||| ckWARN_d||| ckWARN|5.006000||p ck_entersub_args_core||| ck_entersub_args_list||5.013006| ck_entersub_args_proto_or_list||5.013006| ck_entersub_args_proto||5.013006| ck_warner_d||5.011001|v ck_warner||5.011001|v ckwarn_common||| ckwarn_d||5.009003| ckwarn||5.009003| clear_defarray||5.023008| clear_special_blocks||| clone_params_del|||n clone_params_new|||n closest_cop||| cntrl_to_mnemonic|||n compute_EXACTish|||n construct_ahocorasick_from_trie||| cop_free||| cop_hints_2hv||5.013007| cop_hints_fetch_pvn||5.013007| cop_hints_fetch_pvs||5.013007| cop_hints_fetch_pv||5.013007| cop_hints_fetch_sv||5.013007| cophh_2hv||5.013007| cophh_copy||5.013007| cophh_delete_pvn||5.013007| cophh_delete_pvs||5.013007| cophh_delete_pv||5.013007| cophh_delete_sv||5.013007| cophh_fetch_pvn||5.013007| cophh_fetch_pvs||5.013007| cophh_fetch_pv||5.013007| cophh_fetch_sv||5.013007| cophh_free||5.013007| cophh_new_empty||5.024000| cophh_store_pvn||5.013007| cophh_store_pvs||5.013007| cophh_store_pv||5.013007| cophh_store_sv||5.013007| core_prototype||| coresub_op||| cr_textfilter||| croak_caller|||vn croak_memory_wrap|5.019003||pn croak_no_mem|||n croak_no_modify|5.013003||pn croak_nocontext|||pvn croak_popstack|||n croak_sv|5.013001||p croak_xs_usage|5.010001||pn croak|||v csighandler||5.009003|n current_re_engine||| curse||| custom_op_desc||5.007003| custom_op_get_field||| custom_op_name||5.007003| custom_op_register||5.013007| custom_op_xop||5.013007| cv_clone_into||| cv_clone||| cv_const_sv_or_av|||n cv_const_sv||5.003070|n cv_dump||| cv_forget_slab||| cv_get_call_checker_flags||| cv_get_call_checker||5.013006| cv_name||5.021005| cv_set_call_checker_flags||5.021004| cv_set_call_checker||5.013006| cv_undef_flags||| cv_undef||| cvgv_from_hek||| cvgv_set||| cvstash_set||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.024000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v defelem_target||| del_sv||| delimcpy_no_escape|||n delimcpy||5.004000|n despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_sv|5.013001||p die_unwind||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_close||| do_delete_local||| do_dump_pad||| do_eof||| do_exec3||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_ncmp||| do_oddball||| do_op_dump||5.006000| do_open9||5.006000| do_openn||5.007001| do_open||5.003070| do_pmop_dump||5.006000| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| does_utf8_overflow|||n doeval_compile||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogivenfor||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| drand48_init_r|||n drand48_r|||n dtrace_probe_call||| dtrace_probe_load||| dtrace_probe_op||| dtrace_probe_phase||| dump_all_perl||| dump_all||5.006000| dump_c_backtrace||| dump_eval||5.006000| dump_exec_pos||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs_perl||| dump_packsubs||5.006000| dump_regex_sets_structures||| dump_sub_perl||| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| dup_warnings||| edit_distance|||n emulate_setlocale|||n eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| finalize_optree||| finalize_op||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_default_stash||| find_hash_subscript||| find_in_my_stash||| find_lexical_cv||| find_next_masked|||n find_runcv_where||| find_runcv||5.008001| find_rundefsv||5.013002| find_script||| find_span_end_mask|||n find_span_end|||n first_symbol|||n fixup_errno_string||| foldEQ_latin1_s2_folded|||n foldEQ_latin1||5.013008|n foldEQ_locale||5.013002|n foldEQ_utf8||5.013002| foldEQ||5.013002|n fold_constants||| forbid_setid||| force_ident_maybe_lex||| force_ident||| force_list||| force_next||| force_strict_version||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_c_backtrace||| free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_ANYOFM_contents||| get_ANYOF_cp_list_for_ssc||| get_and_check_backslash_N_name_wrapper||| get_and_check_backslash_N_name||| get_aux_mg||| get_av|5.006000||p get_c_backtrace_dump||| get_c_backtrace||| get_context||5.006000|n get_cvn_flags||| get_cvs|5.011000||p get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| gp_dup||| gp_free||| gp_ref||| grok_atoUV|||n grok_bin|5.007003||p grok_bslash_N||| grok_hex|5.007003||p grok_infnan||5.021004| grok_number_flags||5.021002| grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_add_by_type||5.011000| gv_autoload4||5.004000| gv_autoload_pvn||5.015004| gv_autoload_pv||5.015004| gv_autoload_sv||5.015004| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.003070| gv_efullname4||5.006001| gv_efullname||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmeth_internal||| gv_fetchmeth_pv_autoload||5.015004| gv_fetchmeth_pvn_autoload||5.015004| gv_fetchmeth_pvn||5.015004| gv_fetchmeth_pv||5.015004| gv_fetchmeth_sv_autoload||5.015004| gv_fetchmeth_sv||5.015004| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||| gv_fullname3||5.003070| gv_fullname4||5.006001| gv_fullname||| gv_handler||5.007001| gv_init_pvn||| gv_init_pv||5.015004| gv_init_svtype||| gv_init_sv||5.015004| gv_init||| gv_is_in_main||| gv_magicalize_isa||| gv_magicalize||| gv_name_set||5.009004| gv_override||| gv_setref||| gv_stashpvn_internal||| gv_stashpvn|5.003070||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsvpvn_cached||| gv_stashsv||| handle_named_backref||| handle_possible_posix||| handle_regex_sets||| handle_user_defined_property||| he_dup||| hek_dup||| hfree_next_entry||| hsplit||| hv_assert||| hv_auxinit_internal|||n hv_auxinit||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||5.009004| hv_delayfree_ent||5.004000| hv_delete_ent||5.003070| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_ename_add||| hv_ename_delete||| hv_exists_ent||5.003070| hv_exists||| hv_fetch_ent||5.003070| hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent_ret||| hv_free_entries||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.003070| hv_iterkey||| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_ksplit||5.003070| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||| hv_placeholders_set||5.009003| hv_pushkv||| hv_rand_set||5.018000| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.003070| hv_stores|5.009004||p hv_store||| hv_undef_flags||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_constants||| init_dbargs||| init_debugger||| init_global_struct||| init_ids||| init_interp||| init_main_stash||| init_named_cv||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| init_uniprops||| inplace_aassign||| instr|||n intro_my||5.004000| intuit_method||| intuit_more||| invert||| invoke_exception_hook||| io_close||| isALNUMC_A|||p isALNUMC|5.006000||p isALNUM_A|||p isALNUM|||p isALPHANUMERIC_A|||p isALPHANUMERIC|5.017008|5.017008|p isALPHA_A|||p isALPHA|||p isASCII_A|||p isASCII|5.006000||p isBLANK_A|||p isBLANK|5.006001||p isC9_STRICT_UTF8_CHAR|||n isCNTRL_A|||p isCNTRL|5.006000||p isDIGIT_A|||p isDIGIT|||p isFF_OVERLONG|||n isFOO_utf8_lc||| isGCB||| isGRAPH_A|||p isGRAPH|5.006000||p isIDCONT_A|||p isIDCONT|5.017008|5.017008|p isIDFIRST_A|||p isIDFIRST|||p isLB||| isLOWER_A|||p isLOWER|||p isOCTAL_A|||p isOCTAL|5.013005|5.013005|p isPRINT_A|||p isPRINT|5.004000||p isPSXSPC_A|||p isPSXSPC|5.006001||p isPUNCT_A|||p isPUNCT|5.006000||p isSB||| isSCRIPT_RUN||| isSPACE_A|||p isSPACE|||p isSTRICT_UTF8_CHAR|||n isUPPER_A|||p isUPPER|||p isUTF8_CHAR_flags||| isUTF8_CHAR||5.021001|n isWB||| isWORDCHAR_A|||p isWORDCHAR|5.013006|5.013006|p isXDIGIT_A|||p isXDIGIT|5.006000||p is_an_int||| is_ascii_string||5.011000|n is_c9strict_utf8_string_loclen|||n is_c9strict_utf8_string_loc|||n is_c9strict_utf8_string|||n is_handle_constructor|||n is_invariant_string||5.021007|n is_lvalue_sub||5.007001| is_safe_syscall||5.019004| is_ssc_worth_it|||n is_strict_utf8_string_loclen|||n is_strict_utf8_string_loc|||n is_strict_utf8_string|||n is_utf8_char_buf||5.015008|n is_utf8_common_with_len||| is_utf8_common||| is_utf8_cp_above_31_bits|||n is_utf8_fixed_width_buf_flags|||n is_utf8_fixed_width_buf_loc_flags|||n is_utf8_fixed_width_buf_loclen_flags|||n is_utf8_invariant_string_loc|||n is_utf8_invariant_string|||n is_utf8_non_invariant_string|||n is_utf8_overlong_given_start_byte_ok|||n is_utf8_string_flags|||n is_utf8_string_loc_flags|||n is_utf8_string_loclen_flags|||n is_utf8_string_loclen||5.009003|n is_utf8_string_loc||5.008001|n is_utf8_string||5.006001|n is_utf8_valid_partial_char_flags|||n is_utf8_valid_partial_char|||n isa_lookup||| isinfnansv||| isinfnan||5.021004|n items|||n ix|||n jmaybe||| join_exact||| keyword_plugin_standard||| keyword||| leave_scope||| lex_stuff_pvs||5.013005| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.010001||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.010001||p mXPUSHu|5.009002||p magic_clear_all_env||| magic_cleararylen_p||| magic_clearenv||| magic_clearhints||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_copycallchecker||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdebugvar||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_methcall1||| magic_methcall|||v magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdebugvar||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setlvref||| magic_setmglob||| magic_setnkeys||| magic_setnonelem||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||5.021001| matcher_matches_sv||| maybe_multimagic_gv||| mayberelocate||| measure_struct||| memEQs|5.009005||p memEQ|5.004000||p memNEs|5.009005||p memNE|5.004000||p mem_collxfrm||| mem_log_alloc|||n mem_log_common|||n mem_log_free|||n mem_log_realloc|||n mess_alloc||| mess_nocontext|||pvn mess_sv|5.013001||p mess|5.006000||pv mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find_mglob||| mg_findext|5.013008||pn mg_find|||n mg_free_type||5.013006| mg_freeext||| mg_free||| mg_get||| mg_localize||| mg_magical|||n mg_set||| mg_size||5.005000| mini_mktime||5.007002|n minus_v||| missingterm||| mode_from_discipline||| modkids||| more_bodies||| more_sv||| moreswitches||| move_proto_attr||| mro_clean_isarev||| mro_gather_and_rename||| mro_get_from_name||5.010001| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.010001| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_package_moved||| mro_register||5.010001| mro_set_mro||5.010001| mro_set_private_data||5.010001| mul128||| multiconcat_stringify||| multideref_stringify||| my_atof2||5.007002| my_atof3||| my_atof||5.006000| my_attrs||| my_bytes_to_utf8|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005|n my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_kid||| my_lstat_flags||| my_lstat||5.024000| my_memrchr|||n my_mkostemp|||n my_mkstemp_cloexec|||n my_mkstemp|||n my_nl_langinfo|||n my_pclose||5.003070| my_popen_list||5.007001| my_popen||5.003070| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat_flags||| my_stat||5.024000| my_strerror||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_strnlen|||pn my_strtod|||n my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB_x||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB_flags||5.015006| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||5.021006| newFORM||| newFOROP||5.013007| newGIVENOP||5.009003| newGIVWHENOP||| newGVOP||| newGVREF||| newGVgen_flags||5.015004| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMETHOP_internal||| newMETHOP_named||5.021005| newMETHOP||5.021005| newMYSUB||5.017004| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSTUB||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVavdefelem||| newSVhek||5.009003| newSViv||| newSVnv||| newSVpadname||5.017004| newSVpv_share||5.013006| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.010001||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.010001||p newSVpvn|5.004050||p newSVpvs_flags|5.010001||p newSVpvs_share|5.009003||p newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv_flags||| newSVsv_nomg||| newSVsv||| newSVuv|5.006000||p newSV||| newUNOP_AUX||5.021007| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.013007| newXS_deffile||| newXS_len_flags||| newXSproto||5.006000| newXS||5.006000| new_collate||| new_constant||| new_ctype||| new_he||| new_logop||| new_msg_hv||| new_numeric||| new_regcurly|||n new_stackinfo||5.005000| new_version||5.009000| next_symbol||| nextargv||| nextchar||| ninstr|||n no_bareword_allowed||| no_fh_allowed||| no_op||| noperl_die|||vn not_a_number||| not_incrementable||| nothreadhook||5.008000| notify_parser_that_changed_to_utf8||| nuke_stacks||| num_overflow|||n oopsAV||| oopsHV||| op_append_elem||5.013006| op_append_list||5.013006| op_class||| op_clear||| op_contextualize||5.013006| op_convert_list||5.021006| op_dump||5.006000| op_free||| op_integerize||| op_linklist||5.013006| op_lvalue_flags||| op_null||5.007002| op_parent|||n op_prepend_elem||5.013006| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_relocate_sv||| op_sibling_splice||5.021002|n op_std_init||| open_script||| openn_cleanup||| openn_setup||| opmethod_stash||| opslab_force_free||| opslab_free_nopad||| opslab_free||| optimize_optree||| optimize_op||| output_posix_warnings||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package_version||| package||| packlist||5.008001| pad_add_anon||5.008001| pad_add_name_pvn||5.015001| pad_add_name_pvs||5.015001| pad_add_name_pv||5.015001| pad_add_name_sv||5.015001| pad_add_weakref||| pad_alloc_name||| pad_block_start||| pad_check_dup||| pad_compname_type||5.009003| pad_findlex||| pad_findmy_pvn||5.015001| pad_findmy_pvs||5.015001| pad_findmy_pv||5.015001| pad_findmy_sv||5.015001| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||5.008001| pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| padlist_dup||| padlist_store||| padname_dup||| padname_free||| padnamelist_dup||| padnamelist_free||| parse_body||| parse_gv_stash_name||| parse_ident||| parse_lparen_question_flags||| parse_unicode_opts||| parse_uniprop_string||| parser_dup||| parser_free_nexttoke_ops||| parser_free||| path_is_searchable|||n peep||| pending_ident||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmop_dump||5.006000| pmruntime||| pmtrans||| pop_scope||| populate_ANYOF_from_invlist||| populate_isa|||v pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prescan_version||5.011004| print_bytes_for_locale||| print_collxfrm_input_and_return||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_hash|||n ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_charclass_bitmap_innards_common||| put_charclass_bitmap_innards_invlist||| put_charclass_bitmap_innards||| put_code_point||| put_range||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| quadmath_format_needed|||n quadmath_format_single|||n re_compile||5.009005| re_croak2||| re_dup_guts||| re_exec_indentf|||v re_indentf|||v re_intuit_start||5.019001| re_intuit_string||5.006000| re_op_compile||| re_printf|||v realloc||5.007002|n reentrant_free||5.024000| reentrant_init||5.024000| reentrant_retry||5.024000|vn reentrant_size||5.024000| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch_pvn||| refcounted_he_fetch_pvs||| refcounted_he_fetch_pv||| refcounted_he_fetch_sv||| refcounted_he_free||| refcounted_he_inc||| refcounted_he_new_pvn||| refcounted_he_new_pvs||| refcounted_he_new_pv||| refcounted_he_new_sv||| refcounted_he_value||| refkids||| refto||| ref||5.024000| reg2Lanode||| reg_check_named_buff_matched|||n reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_scan_name||| reg_skipcomment|||n reg_temp_copy||| reganode||| regatom||| regbranch||| regclass||| regcp_restore||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump_intflags||| regdump||5.005000| regdupe_internal||| regex_set_precedence|||n regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regnode_guts||| regpiece||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reg||| repeatcpy|||n report_evil_fh||| report_redefined_cv||| report_uninit||| report_wrongway_fh||| require_pv||5.006000| require_tie_mod||| restore_magic||| restore_switched_locale||| rninstr|||n rpeep||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rv2cv_op_cv||5.013006| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem_flags||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hdelete||5.011000| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||5.010001| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic_flags||| save_mortalizesv||5.007001| save_nogv||| save_op||5.005000| save_padsv_and_mortalize||5.010001| save_pptr||| save_pushi32ptr||5.010001| save_pushptri32ptr||| save_pushptrptr||5.010001| save_pushptr||5.010001| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_strlen||| save_svref||| save_to_buffer|||n save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpvs||5.013006| savesharedpv||5.007003| savesharedsvpv||5.013006| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| search_const||| seed||5.008001| sequence_num||| set_ANYOF_arg||| set_caret_X||| set_context||5.006000|n set_numeric_radix||5.006000| set_numeric_standard||5.006000| set_numeric_underlying||| set_padlist|||n set_regex_pv||| setdefout||| setfd_cloexec_for_nonsysfd||| setfd_cloexec_or_inhexec_by_sysfdness||| setfd_cloexec|||n setfd_inhexec_for_sysfd||| setfd_inhexec|||n setlocale_debug_string|||n share_hek_flags||| share_hek||5.004000| should_warn_nl|||n si_dup||| sighandler|||n simplify_sort||| skip_to_be_ignored_text||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| ssc_add_range||| ssc_and||| ssc_anything||| ssc_clear_locale|||n ssc_cp_and||| ssc_finalize||| ssc_init||| ssc_intersection||| ssc_is_anything|||n ssc_is_cp_posixl_init|||n ssc_or||| ssc_union||| stack_grow||| start_subparse||5.004000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool_flags||5.013006| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2nv_flags||5.013001| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff|||n sv_bless||| sv_buf_to_ro||| sv_buf_to_rw||| sv_cat_decode||5.008001| sv_catpv_flags||5.013006| sv_catpv_mg|5.004050||p sv_catpv_nomg||5.013006| sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs_flags||5.013006| sv_catpvs_mg||5.013006| sv_catpvs_nomg||5.013006| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_flags||5.013006| sv_cmp_locale_flags||5.013006| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm_flags||5.013006| sv_collxfrm||| sv_copypv_flags||5.017002| sv_copypv_nomg||5.017002| sv_copypv||| sv_dec_nomg||5.013002| sv_dec||| sv_del_backref||| sv_derived_from_pvn||5.015004| sv_derived_from_pv||5.015004| sv_derived_from_sv||5.015004| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_display||| sv_does_pvn||5.015004| sv_does_pv||5.015004| sv_does_sv||5.015004| sv_does||5.009004| sv_dump||| sv_dup_common||| sv_dup_inc_multiple||| sv_dup_inc||| sv_dup||| sv_eq_flags||5.013006| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free_arenas||| sv_free||| sv_gets||5.003070| sv_grow||| sv_i_ncmp||| sv_inc_nomg||5.013002| sv_inc||| sv_insert_flags||5.010001| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_len_utf8_nomg||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.024000|5.004000|p sv_magicext_mglob||| sv_magicext||5.007003| sv_magic||| sv_mortalcopy_flags||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_only_taint_gmagic|||n sv_or_pv_pos_u2b||| sv_peek||5.005000| sv_pos_b2u_flags||5.019003| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_flags||5.011005| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_ref||5.015004| sv_replace||| sv_report_used||| sv_resetpvn||| sv_reset||| sv_rvunweaken||| sv_rvweaken||5.006000| sv_set_undef||| sv_sethek||| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_bufsize||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs_mg||5.013006| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pvs||5.024000| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_string_from_errnum||| sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagicext|5.013008||p sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||| sv_utf8_downgrade||| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn_flags||5.017002| sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p svtype||| swallow_bom||| swatch_get||| switch_category_locale_to_template||| switch_to_global_locale|||n sync_locale||5.021004|n sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tied_method|||v tmps_grow_p||| toFOLD_utf8_safe||| toFOLD_utf8||5.019001| toFOLD_uvchr||5.023009| toFOLD||5.019001| toLOWER_L1||5.019001| toLOWER_LC||5.004000| toLOWER_utf8_safe||| toLOWER_utf8||5.015007| toLOWER_uvchr||5.023009| toLOWER||| toTITLE_utf8_safe||| toTITLE_utf8||5.015007| toTITLE_uvchr||5.023009| toTITLE||5.019001| toUPPER_utf8_safe||| toUPPER_utf8||5.015007| toUPPER_uvchr||5.023009| toUPPER||| to_byte_substr||| to_lower_latin1|||n to_utf8_substr||| tokenize_use||| tokeq||| tokereport||| too_few_arguments_pv||| too_many_arguments_pv||| translate_substr_offsets|||n traverse_op_tree||| try_amagic_bin||| try_amagic_un||| turkic_fc||| turkic_lc||| turkic_uc||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unreferenced_to_tmp_stack||| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.003070| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop_back|||n utf8_hop_forward|||n utf8_hop_safe|||n utf8_hop||5.006000|n utf8_length||5.007001| utf8_mg_len_cache_update||| utf8_mg_pos_cache_update||| utf8_to_uvchr_buf|5.015009|5.015009|p utf8_to_uvchr|||p utf8n_to_uvchr_error|||n utf8n_to_uvchr||5.007001|n utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||5.007001| uvoffuni_to_utf8_flags||5.019004| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| valid_utf8_to_uvchr|||n validate_suid||| variant_under_utf8_count|||n varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess|5.006000|5.006000|p vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||pvn warn_on_first_deprecated_use||| warn_sv|5.013001||p warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v was_lvalue_sub||| watch||| whichsig_pvn||5.015004| whichsig_pv||5.015004| whichsig_sv||5.015004| whichsig||| win32_croak_not_implemented|||n win32_setlocale||| with_queued_errors||| wrap_op_checker||5.015008| write_to_stderr||| xs_boot_epilog||| xs_handshake|||vn xs_version_bootcheck||| yyerror_pvn||| yyerror_pv||| yyerror||| yylex||| yyparse||| yyquit||| yyunlex||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # 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 D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((D_PPP_DEC2BCD(PERL_REVISION)<<24)|(D_PPP_DEC2BCD(PERL_VERSION)<<12)|D_PPP_DEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef LONGSIZE # define LONGSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef LONGSIZE # define LONGSIZE 4 #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef cBOOL # define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) #endif #ifndef OpHAS_SIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #endif #ifndef OpSIBLING # define OpSIBLING(o) (0 + (o)->op_sibling) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #endif #ifndef OpMAYBESIB_set # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif #ifndef HEf_SVKEY # define HEf_SVKEY -2 #endif #if defined(DEBUGGING) && !defined(__COVERITY__) #ifndef __ASSERT_ # define __ASSERT_(statement) assert(statement), #endif #else #ifndef __ASSERT_ # define __ASSERT_(statement) #endif #endif #ifndef SvRX #if defined(NEED_SvRX) static void * DPPP_(my_SvRX)(pTHX_ SV *rv); static #else extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); #endif #if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) #ifdef SvRX # undef SvRX #endif #define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) void * DPPP_(my_SvRX)(pTHX_ SV *rv) { if (SvROK(rv)) { SV *sv = SvRV(rv); if (SvMAGICAL(sv)) { MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); if (mg && mg->mg_obj) { return mg->mg_obj; } } } return 0; } #endif #endif #ifndef SvRXOK # define SvRXOK(sv) (!!SvRX(sv)) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef PERL_UNUSED_RESULT # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END # else # define PERL_UNUSED_RESULT(v) ((void)(v)) # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #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 DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef av_tindex # define av_tindex AvFILL #endif #ifndef av_top_index # define av_top_index AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef WIDEST_UTYPE # ifdef QUADKIND # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif # else # define WIDEST_UTYPE U32 # endif #endif #ifdef EBCDIC /* This is the first version where these macros are fully correct. Relying on * the C library functions, as earlier releases did, causes problems with * locales */ # if (PERL_BCDVERSION < 0x5022000) # undef isALNUM # undef isALNUM_A # undef isALNUMC # undef isALNUMC_A # undef isALPHA # undef isALPHA_A # undef isALPHANUMERIC # undef isALPHANUMERIC_A # undef isASCII # undef isASCII_A # undef isBLANK # undef isBLANK_A # undef isCNTRL # undef isCNTRL_A # undef isDIGIT # undef isDIGIT_A # undef isGRAPH # undef isGRAPH_A # undef isIDCONT # undef isIDCONT_A # undef isIDFIRST # undef isIDFIRST_A # undef isLOWER # undef isLOWER_A # undef isOCTAL # undef isOCTAL_A # undef isPRINT # undef isPRINT_A # undef isPSXSPC # undef isPSXSPC_A # undef isPUNCT # undef isPUNCT_A # undef isSPACE # undef isSPACE_A # undef isUPPER # undef isUPPER_A # undef isWORDCHAR # undef isWORDCHAR_A # undef isXDIGIT # undef isXDIGIT_A # endif #ifndef isASCII # define isASCII(c) (isCNTRL(c) || isPRINT(c)) #endif /* The below is accurate for all EBCDIC code pages supported by * all the versions of Perl overridden by this */ #ifndef isCNTRL # define isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \ || (c) == '\f' || (c) == '\n' || (c) == '\r' \ || (c) == '\t' || (c) == '\v' \ || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */ \ || (c) == 7 /* U+7F DEL */ \ || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */ \ /* DLE, DC[1-3] */ \ || (c) == 0x18 /* U+18 CAN */ \ || (c) == 0x19 /* U+19 EOM */ \ || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */ \ || (c) == 0x26 /* U+17 ETB */ \ || (c) == 0x27 /* U+1B ESC */ \ || (c) == 0x2D /* U+05 ENQ */ \ || (c) == 0x2E /* U+06 ACK */ \ || (c) == 0x32 /* U+16 SYN */ \ || (c) == 0x37 /* U+04 EOT */ \ || (c) == 0x3C /* U+14 DC4 */ \ || (c) == 0x3D /* U+15 NAK */ \ || (c) == 0x3F /* U+1A SUB */ \ ) #endif /* The ordering of the tests in this and isUPPER are to exclude most characters * early */ #ifndef isLOWER # define isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \ && ( (c) <= 'i' \ || ((c) >= 'j' && (c) <= 'r') \ || (c) >= 's')) #endif #ifndef isUPPER # define isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \ && ( (c) <= 'I' \ || ((c) >= 'J' && (c) <= 'R') \ || (c) >= 'S')) #endif #else /* Above is EBCDIC; below is ASCII */ # if (PERL_BCDVERSION < 0x5004000) /* The implementation of these in older perl versions can give wrong results if * the C program locale is set to other than the C locale */ # undef isALNUM # undef isALNUM_A # undef isALPHA # undef isALPHA_A # undef isDIGIT # undef isDIGIT_A # undef isIDFIRST # undef isIDFIRST_A # undef isLOWER # undef isLOWER_A # undef isUPPER # undef isUPPER_A # endif # if (PERL_BCDVERSION < 0x5008000) /* Hint: isCNTRL * Earlier perls omitted DEL */ # undef isCNTRL # endif # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # undef isPRINT_A # endif # if (PERL_BCDVERSION < 0x5014000) /* Hint: isASCII * The implementation in older perl versions always returned true if the * parameter was a signed char */ # undef isASCII # undef isASCII_A # endif # if (PERL_BCDVERSION < 0x5020000) /* Hint: isSPACE * The implementation in older perl versions didn't include \v */ # undef isSPACE # undef isSPACE_A # endif #ifndef isASCII # define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) #endif #ifndef isLOWER # define isLOWER(c) ((c) >= 'a' && (c) <= 'z') #endif #ifndef isUPPER # define isUPPER(c) ((c) <= 'Z' && (c) >= 'A') #endif #endif /* Below are definitions common to EBCDIC and ASCII */ #ifndef isALNUM # define isALNUM(c) isWORDCHAR(c) #endif #ifndef isALNUMC # define isALNUMC(c) isALPHANUMERIC(c) #endif #ifndef isALPHA # define isALPHA(c) (isUPPER(c) || isLOWER(c)) #endif #ifndef isALPHANUMERIC # define isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifndef isDIGIT # define isDIGIT(c) ((c) <= '9' && (c) >= '0') #endif #ifndef isGRAPH # define isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) #endif #ifndef isIDCONT # define isIDCONT(c) isWORDCHAR(c) #endif #ifndef isIDFIRST # define isIDFIRST(c) (isALPHA(c) || (c) == '_') #endif #ifndef isOCTAL # define isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') #endif #ifndef isPRINT # define isPRINT(c) (isGRAPH(c) || (c) == ' ') #endif #ifndef isPSXSPC # define isPSXSPC(c) isSPACE(c) #endif #ifndef isPUNCT # define isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ || (c) == '#' || (c) == '$' || (c) == '%' \ || (c) == '&' || (c) == '\'' || (c) == '(' \ || (c) == ')' || (c) == '*' || (c) == '+' \ || (c) == ',' || (c) == '.' || (c) == '/' \ || (c) == ':' || (c) == ';' || (c) == '<' \ || (c) == '=' || (c) == '>' || (c) == '?' \ || (c) == '@' || (c) == '[' || (c) == '\\' \ || (c) == ']' || (c) == '^' || (c) == '_' \ || (c) == '`' || (c) == '{' || (c) == '|' \ || (c) == '}' || (c) == '~') #endif #ifndef isSPACE # define isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ || (c) == '\v' || (c) == '\f') #endif #ifndef isWORDCHAR # define isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') #endif #ifndef isXDIGIT # define isXDIGIT(c) ( isDIGIT(c) \ || ((c) >= 'a' && (c) <= 'f') \ || ((c) >= 'A' && (c) <= 'F')) #endif #ifndef isALNUM_A # define isALNUM_A isALNUM #endif #ifndef isALNUMC_A # define isALNUMC_A isALNUMC #endif #ifndef isALPHA_A # define isALPHA_A isALPHA #endif #ifndef isALPHANUMERIC_A # define isALPHANUMERIC_A isALPHANUMERIC #endif #ifndef isASCII_A # define isASCII_A isASCII #endif #ifndef isBLANK_A # define isBLANK_A isBLANK #endif #ifndef isCNTRL_A # define isCNTRL_A isCNTRL #endif #ifndef isDIGIT_A # define isDIGIT_A isDIGIT #endif #ifndef isGRAPH_A # define isGRAPH_A isGRAPH #endif #ifndef isIDCONT_A # define isIDCONT_A isIDCONT #endif #ifndef isIDFIRST_A # define isIDFIRST_A isIDFIRST #endif #ifndef isLOWER_A # define isLOWER_A isLOWER #endif #ifndef isOCTAL_A # define isOCTAL_A isOCTAL #endif #ifndef isPRINT_A # define isPRINT_A isPRINT #endif #ifndef isPSXSPC_A # define isPSXSPC_A isPSXSPC #endif #ifndef isPUNCT_A # define isPUNCT_A isPUNCT #endif #ifndef isSPACE_A # define isSPACE_A isSPACE #endif #ifndef isUPPER_A # define isUPPER_A isUPPER #endif #ifndef isWORDCHAR_A # define isWORDCHAR_A isWORDCHAR #endif #ifndef isXDIGIT_A # define isXDIGIT_A isXDIGIT #endif /* Until we figure out how to support this in older perls... */ #if (PERL_BCDVERSION >= 0x5008000) #ifndef HeUTF8 # define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he)) #endif #endif #ifndef C_ARRAY_LENGTH # define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif #ifndef C_ARRAY_END # define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) #endif #ifndef LIKELY # define LIKELY(x) (x) #endif #ifndef UNLIKELY # define UNLIKELY(x) (x) #endif #ifndef UNICODE_REPLACEMENT # define UNICODE_REPLACEMENT 0xFFFD #endif #ifndef MUTABLE_PTR #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) #else # define MUTABLE_PTR(p) ((void *) (p)) #endif #endif #ifndef MUTABLE_SV # define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) #define Perl_warner DPPP_(my_warner) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif #define _ppport_MIN(a,b) (((a) <= (b)) ? (a) : (b)) #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #if defined UTF8SKIP /* Don't use official version because it uses MIN, which may not be available */ #undef UTF8_SAFE_SKIP #ifndef UTF8_SAFE_SKIP # define UTF8_SAFE_SKIP(s, e) ( \ ((((e) - (s)) <= 0) \ ? 0 \ : _ppport_MIN(((e) - (s)), UTF8SKIP(s)))) #endif #endif #if !defined(my_strnlen) #if defined(NEED_my_strnlen) static STRLEN DPPP_(my_my_strnlen)(const char *str, Size_t maxlen); static #else extern STRLEN DPPP_(my_my_strnlen)(const char *str, Size_t maxlen); #endif #if defined(NEED_my_strnlen) || defined(NEED_my_strnlen_GLOBAL) #define my_strnlen DPPP_(my_my_strnlen) #define Perl_my_strnlen DPPP_(my_my_strnlen) STRLEN DPPP_(my_my_strnlen)(const char *str, Size_t maxlen) { const char *p = str; while(maxlen-- && *p) p++; return p - str; } #endif #endif #if (PERL_BCDVERSION < 0x5031002) /* Versions prior to this accepted things that are now considered * malformations, and didn't return -1 on error with warnings enabled * */ # undef utf8_to_uvchr_buf #endif /* This implementation brings modern, generally more restricted standards to * utf8_to_uvchr_buf. Some of these are security related, and clearly must * be done. But its arguable that the others need not, and hence should not. * The reason they're here is that a module that intends to play with the * latest perls shoud be able to work the same in all releases. An example is * that perl no longer accepts any UV for a code point, but limits them to * IV_MAX or below. This is for future internal use of the larger code points. * If it turns out that some of these changes are breaking code that isn't * intended to work with modern perls, the tighter restrictions could be * relaxed. khw thinks this is unlikely, but has been wrong in the past. */ #ifndef utf8_to_uvchr_buf /* Choose which underlying implementation to use. At least one must be * present or the perl is too early to handle this function */ # if defined(utf8n_to_uvchr) || defined(utf8_to_uv) # if defined(utf8n_to_uvchr) /* This is the preferred implementation */ # define _ppport_utf8_to_uvchr_buf_callee utf8n_to_uvchr # else # define _ppport_utf8_to_uvchr_buf_callee utf8_to_uv # endif # endif #ifdef _ppport_utf8_to_uvchr_buf_callee # if defined(NEED_utf8_to_uvchr_buf) static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); static #else extern UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); #endif #if defined(NEED_utf8_to_uvchr_buf) || defined(NEED_utf8_to_uvchr_buf_GLOBAL) #ifdef utf8_to_uvchr_buf # undef utf8_to_uvchr_buf #endif #define utf8_to_uvchr_buf(a,b,c) DPPP_(my_utf8_to_uvchr_buf)(aTHX_ a,b,c) #define Perl_utf8_to_uvchr_buf DPPP_(my_utf8_to_uvchr_buf) UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) { UV ret; STRLEN curlen; bool overflows = 0; const U8 *cur_s = s; const bool do_warnings = ckWARN_d(WARN_UTF8); if (send > s) { curlen = send - s; } else { assert(0); /* Modern perls die under this circumstance */ curlen = 0; if (! do_warnings) { /* Handle empty here if no warnings needed */ if (retlen) *retlen = 0; return UNICODE_REPLACEMENT; } } /* The modern version allows anything that evaluates to a legal UV, but not * overlongs nor an empty input */ ret = _ppport_utf8_to_uvchr_buf_callee( s, curlen, retlen, (UTF8_ALLOW_ANYUV & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY))); /* But actually, modern versions restrict the UV to being no more than what * an IV can hold */ if (ret > PERL_INT_MAX) { overflows = 1; } # if (PERL_BCDVERSION < 0x5026000) # ifndef EBCDIC /* There are bugs in versions earlier than this on non-EBCDIC platforms * in which it did not detect all instances of overflow, which could be * a security hole. Also, earlier versions did not allow the overflow * malformation under any circumstances, and modern ones do. So we * need to check here. */ else if (curlen > 0 && *s >= 0xFE) { /* If the main routine detected overflow, great; it returned 0. But if the * input's first byte indicates it could overflow, we need to verify. * First, on a 32-bit machine the first byte being at least \xFE * automatically is overflow */ if (sizeof(ret) < 8) { overflows = 1; } else { const U8 highest[] = /* 2*63-1 */ "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"; const U8 *cur_h = highest; for (cur_s = s; cur_s < send; cur_s++, cur_h++) { if (UNLIKELY(*cur_s == *cur_h)) { continue; } /* If this byte is larger than the corresponding highest UTF-8 * byte, the sequence overflows; otherwise the byte is less than * (as we handled the equality case above), and so the sequence * doesn't overflow */ overflows = *cur_s > *cur_h; break; } /* Here, either we set the bool and broke out of the loop, or got * to the end and all bytes are the same which indicates it doesn't * overflow. */ } } # endif # endif /* < 5.26 */ if (UNLIKELY(overflows)) { if (! do_warnings) { if (retlen) { *retlen = _ppport_MIN(*retlen, UTF8SKIP(s)); *retlen = _ppport_MIN(*retlen, curlen); } return UNICODE_REPLACEMENT; } else { /* On versions that correctly detect overflow, but forbid it * always, 0 will be returned, but also a warning will have been * raised. Don't repeat it */ if (ret != 0) { /* We use the error message in use from 5.8-5.14 */ Perl_warner(aTHX_ packWARN(WARN_UTF8), "Malformed UTF-8 character (overflow at 0x%" UVxf ", byte 0x%02x, after start byte 0x%02x)", ret, *cur_s, *s); } if (retlen) { *retlen = (STRLEN) -1; } return 0; } } /* If failed and warnings are off, to emulate the behavior of the real * utf8_to_uvchr(), try again, allowing anything. (Note a return of 0 is * ok if the input was '\0') */ if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) { /* If curlen is 0, we already handled the case where warnings are * disabled, so this 'if' will be true, and we won't look at the * contents of 's' */ if (do_warnings) { *retlen = (STRLEN) -1; } else { ret = _ppport_utf8_to_uvchr_buf_callee( s, curlen, retlen, UTF8_ALLOW_ANY); /* Override with the REPLACEMENT character, as that is what the * modern version of this function returns */ ret = UNICODE_REPLACEMENT; # if (PERL_BCDVERSION < 0x5016000) /* Versions earlier than this don't necessarily return the proper * length. It should not extend past the end of string, nor past * what the first byte indicates the length is, nor past the * continuation characters */ if (retlen && *retlen >= 0) { *retlen = _ppport_MIN(*retlen, curlen); *retlen = _ppport_MIN(*retlen, UTF8SKIP(s)); unsigned int i = 1; do { if (s[i] < 0x80 || s[i] > 0xBF) { *retlen = i; break; } } while (++i < *retlen); } # endif } } return ret; } # endif #endif #endif #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf) #undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses to read past a NUL, making it much less likely to read off the end of the buffer. A NUL indicates the start of the next character anyway. If the input isn't NUL-terminated, the function remains unsafe, as it always has been. */ #ifndef utf8_to_uvchr # define utf8_to_uvchr(s, lp) \ ((*(s) == '\0') \ ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \ : utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp))) #endif #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs # define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif #ifdef NEED_mess_sv #define NEED_mess #endif #ifdef NEED_mess #define NEED_mess_nocontext #define NEED_vmess #endif #ifndef croak_sv #if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) # if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) # define D_PPP_FIX_UTF8_ERRSV(errsv, sv) \ STMT_START { \ if (sv != errsv) \ SvFLAGS(errsv) = (SvFLAGS(errsv) & ~SVf_UTF8) | \ (SvFLAGS(sv) & SVf_UTF8); \ } STMT_END # else # define D_PPP_FIX_UTF8_ERRSV(errsv, sv) STMT_START {} STMT_END # endif # define croak_sv(sv) \ STMT_START { \ if (SvROK(sv)) { \ sv_setsv(ERRSV, sv); \ croak(NULL); \ } else { \ D_PPP_FIX_UTF8_ERRSV(ERRSV, sv); \ croak("%" SVf, SVfARG(sv)); \ } \ } STMT_END #elif (PERL_BCDVERSION >= 0x5004000) # define croak_sv(sv) croak("%" SVf, SVfARG(sv)) #else # define croak_sv(sv) croak("%s", SvPV_nolen(sv)) #endif #endif #ifndef die_sv #if defined(NEED_die_sv) static OP * DPPP_(my_die_sv)(pTHX_ SV *sv); static #else extern OP * DPPP_(my_die_sv)(pTHX_ SV *sv); #endif #if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) #ifdef die_sv # undef die_sv #endif #define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) #define Perl_die_sv DPPP_(my_die_sv) OP * DPPP_(my_die_sv)(pTHX_ SV *sv) { croak_sv(sv); return (OP *)NULL; } #endif #endif #ifndef warn_sv #if (PERL_BCDVERSION >= 0x5004000) # define warn_sv(sv) warn("%" SVf, SVfARG(sv)) #else # define warn_sv(sv) warn("%s", SvPV_nolen(sv)) #endif #endif #ifndef vmess #if defined(NEED_vmess) static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); #endif #if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) #ifdef vmess # undef vmess #endif #define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) #define Perl_vmess DPPP_(my_vmess) SV* DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) { mess(pat, args); return PL_mess_sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) #undef mess #endif #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) #if defined(NEED_mess_nocontext) static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); static #else extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); #endif #if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) #define mess_nocontext DPPP_(my_mess_nocontext) #define Perl_mess_nocontext DPPP_(my_mess_nocontext) SV* DPPP_(my_mess_nocontext)(const char* pat, ...) { dTHX; SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #endif #endif #ifndef mess #if defined(NEED_mess) static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); static #else extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); #endif #if defined(NEED_mess) || defined(NEED_mess_GLOBAL) #define Perl_mess DPPP_(my_mess) SV* DPPP_(my_mess)(pTHX_ const char* pat, ...) { SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #ifdef mess_nocontext #define mess mess_nocontext #else #define mess Perl_mess_nocontext #endif #endif #endif #ifndef mess_sv #if defined(NEED_mess_sv) static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); static #else extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); #endif #if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) #ifdef mess_sv # undef mess_sv #endif #define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) #define Perl_mess_sv DPPP_(my_mess_sv) SV * DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) { SV *tmp; SV *ret; if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { if (consume) return basemsg; ret = mess(""); SvSetSV_nosteal(ret, basemsg); return ret; } if (consume) { sv_catsv(basemsg, mess("")); return basemsg; } ret = mess(""); tmp = newSVsv(ret); SvSetSV_nosteal(ret, basemsg); sv_catsv(ret, tmp); sv_dec(tmp); return ret; } #endif #endif #ifndef warn_nocontext #define warn_nocontext warn #endif #ifndef croak_nocontext #define croak_nocontext croak #endif #ifndef croak_no_modify #define croak_no_modify() croak_nocontext("%s", PL_no_modify) #define Perl_croak_no_modify() croak_no_modify() #endif #ifndef croak_memory_wrap #if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) # define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) #else # define croak_memory_wrap() croak_nocontext("panic: memory wrap") #endif #endif #ifndef croak_xs_usage #if defined(NEED_croak_xs_usage) static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); static #else extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); #endif #if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) #define croak_xs_usage DPPP_(my_croak_xs_usage) #define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) #endif void DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) { dTHX; const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) croak("Usage: %s::%s(%s)", hvname, gvname, params); else croak("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doing. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUEx(ERRSV)) croak_sv(ERRSV); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #elif (PERL_BCDVERSION > 0x5003000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const 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 = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) 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 /* * 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) #ifndef START_MY_CXT /* 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_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = 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 #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #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 /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # elif IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # else # error "cannot define IV/UV formats" # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define D_PPP_SVPV_NOLEN_LP_ARG &PL_na #else # define D_PPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_nomg_nolen # define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 0)) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* Hint: newSVpvn_share * The SVs created by this function only mimic the behaviour of * shared PVs without really being shared. Only use if you know * what you're doing. */ #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef gv_fetchpvn_flags #if defined(NEED_gv_fetchpvn_flags) static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); static #else extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); #endif #if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) #ifdef gv_fetchpvn_flags # undef gv_fetchpvn_flags #endif #define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) #define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { char *namepv = savepvn(name, len); GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); Safefree(namepv); return stash; } #endif #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchsv # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags # define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef gv_init_pvn # define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef newSVpvs_share # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #if !defined(mg_findext) #if defined(NEED_mg_findext) static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); static #else extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); #endif #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) #define mg_findext DPPP_(my_mg_findext) #define Perl_mg_findext DPPP_(my_mg_findext) MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { if (sv) { MAGIC *mg; #ifdef AvPAD_NAMELIST assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); #endif for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && mg->mg_virtual == vtbl) return mg; } } return NULL; } #endif #endif #if !defined(sv_unmagicext) #if defined(NEED_sv_unmagicext) static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); static #else extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); #endif #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) #ifdef sv_unmagicext # undef sv_unmagicext #endif #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) int DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) { MAGIC* mg; MAGIC** mgp; if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(SvMAGIC(sv)); for (mg = *mgp; mg; mg = *mgp) { const MGVTBL* const virt = mg->mg_virtual; if (mg->mg_type == type && virt == vtbl) { *mgp = mg->mg_moremagic; if (virt && virt->svt_free) virt->svt_free(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ mg_magical(sv); /* else fix the flags now */ } else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } return 0; } #endif #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #if (PERL_BCDVERSION >= 0x5006000) #ifndef caller_cx # if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) static I32 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: return i; } } return i; } # endif # if defined(NEED_caller_cx) static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); static #else extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); #endif #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) #ifdef caller_cx # undef caller_cx #endif #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) #define Perl_caller_cx DPPP_(my_caller_cx) const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); register const PERL_CONTEXT *cx; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); } if (cxix < 0) return NULL; /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); } cx = &ccstack[cxix]; if (dbcxp) *dbcxp = cx; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } return cx; } # endif #endif /* caller_cx */ #endif /* 5.6.0 */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) isuni ? utf8_to_uvchr_buf((U8*)pv, end, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%" UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%" UVxf "}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ BerkeleyDB-0.64/Changes0000755000175000017500000004361113730620437013407 0ustar paulpaulRevision history for Perl extension BerkeleyDB. 0.64 17 September 2020 * Refresh ppport.h 2a4ebf00b93977cfbffc65ecbcc0aac4f7cbad1d * Silence clang warning in call to "initial_value" https://github.com/pmqs/BerkeleyDB/issues/4 aa9c569b797bee78141ef319685d756bcef92a18 0.63 21 July 2019 * added 000prereq.t Dump version info in "make test" 9e17580d74662b6a3186990dd3b1469df2829503 0.62 20 July 2019 * default to /usr/local/BerkeleyDB fcc0ad8adf310f7c8cc65788806439f2f8c39f90 * __heap_exist prototype needed for db 5.2 or better 7fe4ad8d74190d7f41a816c79e5ccf044c02c7c9 * t/joint.: Silence Valgrinf https://rt.cpan.org/Ticket/Display.html?id=125605 40d03924570f8516efe4a05982f402e8ce569637 * db_remove missing txn code https://rt.cpan.org/Ticket/Display.html?id=124979 b91875a9f3f55bb779ad7a448c9fff0645d8a527 * Fix test failure when TRACE is enabled bb80b7d0fb83643ccddd8243d4c6b6ab637428df * Added BERKELEYDB_DEFINE_TRACE variable to allow TRACE to be enabled from .travis file. bd9ebf5aa149172afab55d6ba6f27d77cf08d91a * Add test with BERKELEYDB_DEFINE_TRACE set to .travis 000b1d8dffe542d6476fe78f218cc95534f1c1c3 * my_db_strerror: Add missing dTHX declaration Merge pull request https://github.com/pmqs/BerkeleyDB/pull/2 4273345d8eff5f521788b3c5e71fb291bf46a646 80ca9b77968ab84aaf8b546f2933d135202e16e0 * create .appveyor.yml 4e7b034ddbe76a7c2dcd189e1e0c935c1559aa2c * sync dbinfo from DB_File 27b499fa9dbfca78adcc7a12ada43f0b05b6ece6 0.61 30 March 2019 * Fix a couple of typos One's a copyright date out by 20 years. The other one breaks builds with 5.2 ≤ BDB < 6.2. Merge pull request https://github.com/pmqs/BerkeleyDB/pull/1 0.60 30 March 2019 * Moved source to github https://github.com/pmqs/BerkeleyDB * Add META_MERGE to Makefile.PL * Added meta-json.t & meta-yaml.t 0.58 23 January 2018 * please expose set_lg_filemode [RT #124979] 0.57 23 January 2018 * Updates for BDB 6.3 0.56 5 January 2016 * Updates for BDB 6.2 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.64/BerkeleyDB.pod0000644000175000017500000024025713730613372014572 0ustar paulpaul=head1 NAME BerkeleyDB - Perl extension for Berkeley DB version 2, 3, 4, 5 or 6 =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. An example is when you need to encode your data in UTF-8 before writing to the database and then decode the UTF-8 when reading from the database file. There are two ways to use a DBM Filter. =over 5 =item 1. Using the low-level API defined below. =item 2. Using the L module. This module hides the complexity of the API defined below and comes with a number of "canned" filters that cover some of the common use-cases. =back Use of the L module is recommended. =head2 DBM Filter Low-level API 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 SUPPORT General feedback/questions/bug reports should be sent to L (preferred) or L. =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-2020 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.64/config.in0000644000175000017500000000242513514650472013706 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.64/hints/0000755000175000017500000000000013730620756013235 5ustar paulpaulBerkeleyDB-0.64/hints/solaris.pl0000644000175000017500000000005513426366746015256 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lmt" ]; BerkeleyDB-0.64/hints/irix_6_5.pl0000644000175000017500000000006113426366745015222 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lthread" ]; BerkeleyDB-0.64/hints/dec_osf.pl0000644000175000017500000000006313426366760015177 0ustar paulpaul$self->{LIBS} = [ "@{$self->{LIBS}} -lpthreads" ]; BerkeleyDB-0.64/Makefile.PL0000644000175000017500000000770113524003570014055 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 $TRACE", #'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') : () ), ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { "meta-spec" => { version => 2 }, resources => { bugtracker => { web => 'https://github.com/pmqs/BerkeleyDB/issues' }, homepage => 'https://github.com/pmqs/BerkeleyDB', repository => { type => 'git', url => 'git://github.com/pmqs/BerkeleyDB.git', web => 'https://github.com/pmqs/BerkeleyDB', }, }, } ) : () ), ); 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.64/BerkeleyDB.xs0000644000175000017500000047651713730616201014446 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-2016 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 #if DB_VERSION_MAJOR > 6 || (DB_VERSION_MAJOR == 6 && DB_VERSION_MINOR >= 2) # define AT_LEAST_DB_6_2 #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) do { printf("# "); printf x; fflush(stdout); } while (0) ; #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) /* __heap_exists is not exported by db.h, so include prototype here */ int __heap_exist __P((void)); #else # define isHeapDb(db) (0) # 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) { #ifdef dTHX dTHX; #endif 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 [%lu] 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 [%lu] 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) ; SetValue_ov(txn, "Txn", BerkeleyDB__Txn) ; 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 log_filemode = 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(log_filemode,"LogFileMode") ; 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") ; if (log_filemode) softCrash("-LogFileMode 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 #ifdef AT_LEAST_DB_4_4 if (status == 0 && log_filemode) { status = env->set_lg_filemode(env, log_filemode) ; Trace(("set_lg_filemode [%04o] returned %s\n", log_filemode, 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_filemode(env, filemode) BerkeleyDB::Env env u_int32_t filemode PREINIT: dMY_CXT; INIT: ckActive_Database(env->active) ; CODE: #ifndef AT_LEAST_DB_4_4 softCrash("$env->set_lg_filemode needs Berkeley DB 4.4 or better") ; #else RETVAL = env->Status = env->Env->set_lg_filemode(env->Env, filemode); #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 DualType set_region_dir(env, dir) BerkeleyDB::Env env const char* dir PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_2 softCrash("$env->set_region_dir needs Berkeley DB 6.2 or better") ; #else RETVAL = env->Env->set_region_dir(env->Env, dir); #endif OUTPUT: RETVAL DualType get_region_dir(env, dir) BerkeleyDB::Env env char* dir = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_2 softCrash("$env->get_region_dir needs Berkeley DB 6.2 or better") ; #else RETVAL = env->Env->get_region_dir(env->Env, (const char**)&dir); #endif OUTPUT: RETVAL dir DualType get_slice_count(env, count) BerkeleyDB::Env env u_int32_t count = NO_INIT PREINIT: dMY_CXT; CODE: #ifndef AT_LEAST_DB_6_2 softCrash("$env->get_slice_count needs Berkeley DB 6.2 or better") ; #else RETVAL = env->Env->get_slice_count(env->Env, &count); #endif OUTPUT: RETVAL count 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)(((I64TYPE)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.64/BerkeleyDB/0000755000175000017500000000000013730620756014060 5ustar paulpaulBerkeleyDB-0.64/BerkeleyDB/Hash.pm0000644000175000017500000000012713426366737015311 0ustar paulpaul package BerkeleyDB::Hash ; # This file is only used for MLDBM use BerkeleyDB ; 1 ; BerkeleyDB-0.64/BerkeleyDB/Btree.pm0000644000175000017500000000013013426366737015461 0ustar paulpaul package BerkeleyDB::Btree ; # This file is only used for MLDBM use BerkeleyDB ; 1 ; BerkeleyDB-0.64/scan.pl0000644000175000017500000001327513426367042013377 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]*"), glob("[1-9][0-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.64/BerkeleyDB.pod.P0000755000175000017500000022424713730612623014772 0ustar paulpaul=head1 NAME BerkeleyDB - Perl extension for Berkeley DB version 2, 3, 4, 5 or 6 =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. An example is when you need to encode your data in UTF-8 before writing to the database and then decode the UTF-8 when reading from the database file. There are two ways to use a DBM Filter. =over 5 =item 1. Using the low-level API defined below. =item 2. Using the L module. This module hides the complexity of the API defined below and comes with a number of "canned" filters that cover some of the common use-cases. =back Use of the L module is recommended. =head2 DBM Filter Low-level API 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 SUPPORT General feedback/questions/bug reports should be sent to L (preferred) or L. =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-2020 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.64/patches/0000755000175000017500000000000013730620756013537 5ustar paulpaulBerkeleyDB-0.64/patches/5.004_040000644000175000017500000001502613426366746014447 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.64/patches/5.004_010000644000175000017500000001544013426366746014444 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.64/patches/5.0050000644000175000017500000001600013426366746014136 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.64/patches/5.004_050000644000175000017500000001507013426366746014447 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.64/patches/5.0040000644000175000017500000000500113426366763014133 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.64/patches/5.004_030000644000175000017500000001605413426366746014450 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.64/patches/5.6.00000644000175000017500000002361013426366746014142 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.64/patches/5.005_020000644000175000017500000002203013426366746014437 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.64/patches/5.004_020000644000175000017500000001544013426366746014445 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.64/patches/5.005_010000644000175000017500000001612413426366746014445 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.64/patches/5.005_030000644000175000017500000002063213426366746014446 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.64/typemap0000644000175000017500000002403513426367033013514 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.64/t/0000755000175000017500000000000013730620756012353 5ustar paulpaulBerkeleyDB-0.64/t/examples.t.T0000644000175000017500000002042713426367011014557 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.64/t/txn.t0000644000175000017500000001576013426367005013357 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.64/t/recno.t0000644000175000017500000005260213426367031013647 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.64/t/blob.t0000644000175000017500000000775113426367033013466 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.64/t/unknown.t0000755000175000017500000001125513426367023014243 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.64/t/subdb.t0000644000175000017500000001075713426367005013646 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.64/t/hash.t0000644000175000017500000004375313426367023013474 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.64/t/db-4.6.t0000755000175000017500000001316113426367023013434 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.64/t/pod.t0000644000175000017500000000040413426366773013330 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.64/t/util.pm0000644000175000017500000001474413426367013013674 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.64/t/examples3.t.T0000644000175000017500000000543413426367011014643 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.64/t/encrypt.t0000644000175000017500000004061213426367005014224 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.64/t/queue.t0000644000175000017500000005443013426367031013666 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.64/t/env.t0000644000175000017500000001547213515076631013337 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.64/t/examples.t0000644000175000017500000002000113730613372014343 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.64/t/meta-yaml.t0000644000175000017500000000020513443205013014405 0ustar paulpauluse Test::More; eval "use Test::CPAN::Meta"; plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@; meta_yaml_ok();BerkeleyDB-0.64/t/join.t0000644000175000017500000001373013514641606013500 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.64/t/db-4.3.t0000644000175000017500000000417213426367013013427 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.64/t/db-4.x.t0000755000175000017500000000171013426367005013533 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.64/t/Test/0000755000175000017500000000000013730620756013272 5ustar paulpaulBerkeleyDB-0.64/t/Test/Builder.pm0000644000175000017500000011056113426367005015217 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.64/t/Test/More.pm0000644000175000017500000011136413426367005014535 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.64/t/db-4.4.t0000644000175000017500000000514713426367044013437 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 => 12; { 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"; } { title "Testing lg_filemode"; # switch umask my $omask = umask 077; use Cwd ; my $cwd = cwd() ; my $home = "$cwd/test-log-perms" ; my $data_file = "data.db" ; ok my $lexD = new LexDir($home) ; my $env = new BerkeleyDB::Env -Home => $home, -LogFileMode => 0641, # something weird -Flags => DB_CREATE|DB_INIT_TXN|DB_INIT_LOG| DB_INIT_MPOOL|DB_INIT_LOCK ; ok $env ; # something crazy small #is($env->set_lg_max(1024), 0); 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() ; ok(my ($log) = glob("$home/log.*"), "log.* file is present"); SKIP: { skip "POSIX only", 1 if $^O eq 'MSWin32'; my (undef, undef, $perms) = stat $log; is($perms, 0100641, "log perms match"); }; # meh this one is gonna be harder to test because it would entail # spurring the database into generating a second log file # $env->set_lg_filemode(0777); # $env->txn_checkpoint(0, 0); # $txn = $env->txn_begin; # $txn->Txn(tied %hash); # for my $i (0..10_000) { # $hash{$i} = $i x 10; # } # $txn->txn_commit; # $env->txn_checkpoint(0, 0); #diag(`ls -l $home`); untie %hash ; undef $txn ; undef $env ; umask $omask; } BerkeleyDB-0.64/t/000prereq.t0000644000175000017500000000271113730612323014246 0ustar paulpaulBEGIN { if ($ENV{PERL_CORE}) { chdir 't' if -d 't'; @INC = ("../lib", "lib/compress"); } } use lib qw(t t/compress); use strict ; use warnings ; use Test::More ; use util ; BEGIN { # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; plan tests => 1 + $extra ; use_ok('BerkeleyDB', '0.64'); } if (defined $BerkeleyDB::VERSION) { my $ver = BerkeleyDB::DB_VERSION_STRING(); my $has_heap = 'Not Available' ; if ($BerkeleyDB::db_version >= 5.1) { $has_heap = BerkeleyDB::has_heap() ? 'True' : 'False'; } # Is encryption support available? my $has_encryption = 'Not Available'; if ($BerkeleyDB::db_version >= 4.1) { my $env = new BerkeleyDB::Env @StdErrFile, -Encrypt => {Password => "abc", Flags => DB_ENCRYPT_AES }; $has_encryption = 'True'; $has_encryption = 'False' if $BerkeleyDB::Error =~ /Operation not supported/; } diag < "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.64/t/heap.t0000644000175000017500000003306013426367025013456 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.64/t/db-3.2.t0000644000175000017500000000200413426367005013416 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.64/t/cds.t0000644000175000017500000000253513426367005013313 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.64/t/filter.t0000644000175000017500000002044513426367013014026 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.64/t/db-4.8.t0000644000175000017500000001736713426367023013447 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.64/t/db-4.7.t0000644000175000017500000000134713426367006013436 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.64/t/meta-json.t0000644000175000017500000000022213443204446014424 0ustar paulpauluse Test::More; eval "use Test::CPAN::Meta::JSON"; plan skip_all => "Test::CPAN::Meta::JSON required for testing META.json" if $@; meta_json_ok();BerkeleyDB-0.64/t/mldbm.t0000644000175000017500000000435713426367005013641 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.64/t/sequence.t0000755000175000017500000000220413426367005014346 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.64/t/destroy.t0000644000175000017500000000404313514647533014234 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.64/t/db-3.0.t0000644000175000017500000000302513426367005013420 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.64/t/btree.t0000644000175000017500000005516713426367033013655 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.64/t/db-3.3.t0000644000175000017500000002537713426367022013440 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.64/t/strict.t0000644000175000017500000001220713426367005014047 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.64/t/encode.t0000644000175000017500000000244513426367013013776 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.64/t/db-3.1.t0000644000175000017500000001340613426367005013425 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.64/dbinfo0000755000175000017500000001105213730613137013271 0ustar paulpaul#!/usr/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-2020 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.64/META.json0000664000175000017500000000225613730620756013540 0ustar paulpaul{ "abstract" : "Perl extension for Berkeley DB version 2, 3, 4, 5 or 6", "author" : [ "Paul Marquess " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "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" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/pmqs/BerkeleyDB/issues" }, "homepage" : "https://github.com/pmqs/BerkeleyDB", "repository" : { "type" : "git", "url" : "git://github.com/pmqs/BerkeleyDB.git", "web" : "https://github.com/pmqs/BerkeleyDB" } }, "version" : "0.64", "x_serialization_backend" : "JSON::PP version 4.02" } BerkeleyDB-0.64/META.yml0000664000175000017500000000131213730620756013360 0ustar paulpaul--- abstract: 'Perl extension for Berkeley DB version 2, 3, 4, 5 or 6' author: - 'Paul Marquess ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' 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 resources: bugtracker: https://github.com/pmqs/BerkeleyDB/issues homepage: https://github.com/pmqs/BerkeleyDB repository: git://github.com/pmqs/BerkeleyDB.git version: '0.64' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' BerkeleyDB-0.64/mkconsts.pl0000755000175000017500000011462613426367042014321 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.21 ######### 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_PARTIAL => DEFINE, DB_LOG_VERIFY_VERBOSE => DEFINE, DB_LOG_VERIFY_WARNING => DEFINE, DB_NOERROR => 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.21', LOGREC_ARG => '5.0.21', LOGREC_HDR => '5.0.21', LOGREC_DATA => '5.0.21', LOGREC_DB => '5.0.21', LOGREC_DBOP => '5.0.21', LOGREC_DBT => '5.0.21', LOGREC_LOCKS => '5.0.21', LOGREC_OP => '5.0.21', LOGREC_PGDBT => '5.0.21', LOGREC_PGDDBT => '5.0.21', LOGREC_PGLIST => '5.0.21', LOGREC_POINTER => '5.0.21', LOGREC_TIME => '5.0.21', # enum db_recops DB_TXN_LOG_VERIFY => '5.0.21', ######### # 5.0.32 ######### DBC_ERROR => IGNORE, ######### # 5.1.25 ######### DB_ASSOC_CREATE => DEFINE, DB_DATABASE_LOCK => DEFINE, DB_DATABASE_LOCKING => DEFINE, DB_ENV_DATABASE_LOCKING => DEFINE, DB_ENV_HOTBACKUP => DEFINE, DB_ENV_NOFLUSH => DEFINE, DB_HOTBACKUP_IN_PROGRESS => DEFINE, DB_LOCK_CHECK => DEFINE, DB_LOG_NO_DATA => DEFINE, DB_NOFLUSH => DEFINE, DB_NO_CHECKPOINT => DEFINE, DB_REPMGR_ACKS_ALL_AVAILABLE => DEFINE, DB_TXN_BULK => DEFINE, TXN_BULK => IGNORE, ######### # 5.2.10 ######### 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_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_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.10', # enum DB_MEM_CONFIG DB_MEM_LOCK => '5.2.10', DB_MEM_LOCKOBJECT => '5.2.10', DB_MEM_LOCKER => '5.2.10', DB_MEM_LOGID => '5.2.10', DB_MEM_TRANSACTION => '5.2.10', DB_MEM_THREAD => '5.2.10', ######### # 5.2.28 ######### DB_EVENT_REP_WOULD_ROLLBACK => DEFINE, DB_REP_CONF_AUTOROLLBACK => DEFINE, DB_REP_WOULDROLLBACK => DEFINE, ######### # 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.0.35 ######### DB_NOINTMP => DEFINE, ######### # 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, ######### # 6.1.19 ######### DB_FORCESYNCENV => DEFINE, DB_META_CHKSUM_FAIL => DEFINE, ######### # 6.1.29 ######### DB2_AM_MPOOL_OPENED => DEFINE, ######### # 6.1.36 ######### DB_REGION_MAGIC_RECOVER => DEFINE, ######### # 6.2.23 ######### DB_DBT_EXT_FILE => IGNORE, DB_LOG_EXT_FILE => DEFINE, DB_OFF_T_MAX => DEFINE, DB_REPMGR_CONF_FORWARD_WRITES => DEFINE, DB_REP_WRITE_FORWARD_TIMEOUT => DEFINE, DB_SLICED => DEFINE, DB_SLICE_CORRUPT => DEFINE, DB_VERB_SLICE => DEFINE, ######### # 6.2.32 ######### DB_CONVERT => DEFINE, ######### # 6.3.10 ######### DB_EVENT_REP_AUTOTAKEOVER => DEFINE, DB_REPMGR_CONF_DISABLE_POLL => DEFINE, DB_REPMGR_CONF_ENABLE_EPOLL => DEFINE, DB_REPMGR_ISELECTABLE => DEFINE, DB_REP_INELECT => DEFINE, DB_SYSTEM_MEM_MISSING => DEFINE, DB_TXN_DISPATCH => DEFINE, HAVE_EPOLL => DEFINE, TXN_DISPATCH => IGNORE, # enum poll_method_t SELECT => '6.3.10', POLL => '6.3.10', EPOLL => '6.3.10', # enum DB_MEM_CONFIG DB_MEM_DATABASE => '6.3.10', DB_MEM_DATABASE_LENGTH => '6.3.10', DB_MEM_EXTFILE_DATABASE => '6.3.10', DB_MEM_REP_SITE => '6.3.10', ) ; 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.64/constants.xs0000644000175000017500000000502013730616201014463 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.64/mkpod0000755000175000017500000000574013426366737013166 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.64/Todo0000644000175000017500000000265413426366743012754 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()