diff options
| author | unknown <ram@mysql.r18.ru> | 2002-10-30 15:57:05 +0400 |
|---|---|---|
| committer | unknown <ram@mysql.r18.ru> | 2002-10-30 15:57:05 +0400 |
| commit | 155e78f014de1a2e259ae5119f4621fbb210a784 (patch) | |
| tree | 6881a3cca88bea0bb9eeffd5aae34be437152786 /bdb/perl/DB_File | |
| parent | b8798d25ab71436bf690ee8ae48285a655c5487e (diff) | |
| download | mariadb-git-155e78f014de1a2e259ae5119f4621fbb210a784.tar.gz | |
BDB 4.1.24
BitKeeper/deleted/.del-ex_access.wpj~3df6ae8c99bf7c5f:
Delete: bdb/build_vxworks/ex_access/ex_access.wpj
BitKeeper/deleted/.del-ex_btrec.wpj~a7622f1c6f432dc6:
Delete: bdb/build_vxworks/ex_btrec/ex_btrec.wpj
BitKeeper/deleted/.del-ex_dbclient.wpj~7345440f3b204cdd:
Delete: bdb/build_vxworks/ex_dbclient/ex_dbclient.wpj
BitKeeper/deleted/.del-ex_env.wpj~fbe1ab10b04e8b74:
Delete: bdb/build_vxworks/ex_env/ex_env.wpj
BitKeeper/deleted/.del-ex_mpool.wpj~4479cfd5c45f327d:
Delete: bdb/build_vxworks/ex_mpool/ex_mpool.wpj
BitKeeper/deleted/.del-ex_tpcb.wpj~f78093006e14bf41:
Delete: bdb/build_vxworks/ex_tpcb/ex_tpcb.wpj
BitKeeper/deleted/.del-db_buildall.dsp~bd749ff6da11682:
Delete: bdb/build_win32/db_buildall.dsp
BitKeeper/deleted/.del-cxx_app.cpp~ad8df8e0791011ed:
Delete: bdb/cxx/cxx_app.cpp
BitKeeper/deleted/.del-cxx_log.cpp~a50ff3118fe06952:
Delete: bdb/cxx/cxx_log.cpp
BitKeeper/deleted/.del-cxx_table.cpp~ecd751e79b055556:
Delete: bdb/cxx/cxx_table.cpp
BitKeeper/deleted/.del-namemap.txt~796a3acd3885d8fd:
Delete: bdb/cxx/namemap.txt
BitKeeper/deleted/.del-Design.fileop~3ca4da68f1727373:
Delete: bdb/db/Design.fileop
BitKeeper/deleted/.del-db185_int.h~61bee3736e7959ef:
Delete: bdb/db185/db185_int.h
BitKeeper/deleted/.del-acconfig.h~411e8854d67ad8b5:
Delete: bdb/dist/acconfig.h
BitKeeper/deleted/.del-mutex.m4~a13383cde18a64e1:
Delete: bdb/dist/aclocal/mutex.m4
BitKeeper/deleted/.del-options.m4~b9d0ca637213750a:
Delete: bdb/dist/aclocal/options.m4
BitKeeper/deleted/.del-programs.m4~3ce7890b47732b30:
Delete: bdb/dist/aclocal/programs.m4
BitKeeper/deleted/.del-tcl.m4~f944e2db93c3b6db:
Delete: bdb/dist/aclocal/tcl.m4
BitKeeper/deleted/.del-types.m4~59cae158c9a32cff:
Delete: bdb/dist/aclocal/types.m4
BitKeeper/deleted/.del-script~d38f6d3a4f159cb4:
Delete: bdb/dist/build/script
BitKeeper/deleted/.del-configure.in~ac795a92c8fe049c:
Delete: bdb/dist/configure.in
BitKeeper/deleted/.del-ltconfig~66bbd007d8024af:
Delete: bdb/dist/ltconfig
BitKeeper/deleted/.del-rec_ctemp~a28554362534f00a:
Delete: bdb/dist/rec_ctemp
BitKeeper/deleted/.del-s_tcl~2ffe4326459fcd9f:
Delete: bdb/dist/s_tcl
BitKeeper/deleted/.del-.IGNORE_ME~d8148b08fa7d5d15:
Delete: bdb/dist/template/.IGNORE_ME
BitKeeper/deleted/.del-btree.h~179f2aefec1753d:
Delete: bdb/include/btree.h
BitKeeper/deleted/.del-cxx_int.h~6b649c04766508f8:
Delete: bdb/include/cxx_int.h
BitKeeper/deleted/.del-db.src~6b433ae615b16a8d:
Delete: bdb/include/db.src
BitKeeper/deleted/.del-db_185.h~ad8b373d9391d35c:
Delete: bdb/include/db_185.h
BitKeeper/deleted/.del-db_am.h~a714912b6b75932f:
Delete: bdb/include/db_am.h
BitKeeper/deleted/.del-db_cxx.h~fcafadf45f5d19e9:
Delete: bdb/include/db_cxx.h
BitKeeper/deleted/.del-db_dispatch.h~6844f20f7eb46904:
Delete: bdb/include/db_dispatch.h
BitKeeper/deleted/.del-db_int.src~419a3f48b6a01da7:
Delete: bdb/include/db_int.src
BitKeeper/deleted/.del-db_join.h~76f9747a42c3399a:
Delete: bdb/include/db_join.h
BitKeeper/deleted/.del-db_page.h~e302ca3a4db3abdc:
Delete: bdb/include/db_page.h
BitKeeper/deleted/.del-db_server_int.h~e1d20b6ba3bca1ab:
Delete: bdb/include/db_server_int.h
BitKeeper/deleted/.del-db_shash.h~5fbf2d696fac90f3:
Delete: bdb/include/db_shash.h
BitKeeper/deleted/.del-db_swap.h~1e60887550864a59:
Delete: bdb/include/db_swap.h
BitKeeper/deleted/.del-db_upgrade.h~c644eee73701fc8d:
Delete: bdb/include/db_upgrade.h
BitKeeper/deleted/.del-db_verify.h~b8d6c297c61f342e:
Delete: bdb/include/db_verify.h
BitKeeper/deleted/.del-debug.h~dc2b4f2cf27ccebc:
Delete: bdb/include/debug.h
BitKeeper/deleted/.del-hash.h~2aaa548b28882dfb:
Delete: bdb/include/hash.h
BitKeeper/deleted/.del-lock.h~a761c1b7de57b77f:
Delete: bdb/include/lock.h
BitKeeper/deleted/.del-log.h~ff20184238e35e4d:
Delete: bdb/include/log.h
BitKeeper/deleted/.del-mp.h~7e317597622f3411:
Delete: bdb/include/mp.h
BitKeeper/deleted/.del-mutex.h~d3ae7a2977a68137:
Delete: bdb/include/mutex.h
BitKeeper/deleted/.del-os.h~91867cc8757cd0e3:
Delete: bdb/include/os.h
BitKeeper/deleted/.del-os_jump.h~e1b939fa5151d4be:
Delete: bdb/include/os_jump.h
BitKeeper/deleted/.del-qam.h~6fad0c1b5723d597:
Delete: bdb/include/qam.h
BitKeeper/deleted/.del-queue.h~4c72c0826c123d5:
Delete: bdb/include/queue.h
BitKeeper/deleted/.del-region.h~513fe04d977ca0fc:
Delete: bdb/include/region.h
BitKeeper/deleted/.del-shqueue.h~525fc3e6c2025c36:
Delete: bdb/include/shqueue.h
BitKeeper/deleted/.del-tcl_db.h~c536fd61a844f23f:
Delete: bdb/include/tcl_db.h
BitKeeper/deleted/.del-txn.h~c8d94b221ec147e4:
Delete: bdb/include/txn.h
BitKeeper/deleted/.del-xa.h~ecc466493aae9d9a:
Delete: bdb/include/xa.h
BitKeeper/deleted/.del-DbRecoveryInit.java~756b52601a0b9023:
Delete: bdb/java/src/com/sleepycat/db/DbRecoveryInit.java
BitKeeper/deleted/.del-DbTxnRecover.java~74607cba7ab89d6d:
Delete: bdb/java/src/com/sleepycat/db/DbTxnRecover.java
BitKeeper/deleted/.del-lock_conflict.c~fc5e0f14cf597a2b:
Delete: bdb/lock/lock_conflict.c
BitKeeper/deleted/.del-log.src~53ac9e7b5cb023f2:
Delete: bdb/log/log.src
BitKeeper/deleted/.del-log_findckp.c~24287f008916e81f:
Delete: bdb/log/log_findckp.c
BitKeeper/deleted/.del-log_rec.c~d51711f2cac09297:
Delete: bdb/log/log_rec.c
BitKeeper/deleted/.del-log_register.c~b40bb4efac75ca15:
Delete: bdb/log/log_register.c
BitKeeper/deleted/.del-Design~b3d0f179f2767b:
Delete: bdb/mp/Design
BitKeeper/deleted/.del-os_finit.c~95dbefc6fe79b26c:
Delete: bdb/os/os_finit.c
BitKeeper/deleted/.del-os_abs.c~df95d1e7db81924:
Delete: bdb/os_vxworks/os_abs.c
BitKeeper/deleted/.del-os_finit.c~803b484bdb9d0122:
Delete: bdb/os_vxworks/os_finit.c
BitKeeper/deleted/.del-os_map.c~3a6d7926398b76d3:
Delete: bdb/os_vxworks/os_map.c
BitKeeper/deleted/.del-os_finit.c~19a227c6d3c78ad:
Delete: bdb/os_win32/os_finit.c
BitKeeper/deleted/.del-log-corruption.patch~1cf2ecc7c6408d5d:
Delete: bdb/patches/log-corruption.patch
BitKeeper/deleted/.del-Btree.pm~af6d0c5eaed4a98e:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB/Btree.pm
BitKeeper/deleted/.del-BerkeleyDB.pm~7244036d4482643:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB.pm
BitKeeper/deleted/.del-BerkeleyDB.pod~e7b18fd6132448e3:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB.pod
BitKeeper/deleted/.del-Hash.pm~10292a26c06a5c95:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB/Hash.pm
BitKeeper/deleted/.del-BerkeleyDB.pod.P~79f76a1495eda203:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB.pod.P
BitKeeper/deleted/.del-BerkeleyDB.xs~80c99afbd98e392c:
Delete: bdb/perl.BerkeleyDB/BerkeleyDB.xs
BitKeeper/deleted/.del-Changes~729c1891efa60de9:
Delete: bdb/perl.BerkeleyDB/Changes
BitKeeper/deleted/.del-MANIFEST~63a1e34aecf157a0:
Delete: bdb/perl.BerkeleyDB/MANIFEST
BitKeeper/deleted/.del-Makefile.PL~c68797707d8df87a:
Delete: bdb/perl.BerkeleyDB/Makefile.PL
BitKeeper/deleted/.del-README~5f2f579b1a241407:
Delete: bdb/perl.BerkeleyDB/README
BitKeeper/deleted/.del-Todo~dca3c66c193adda9:
Delete: bdb/perl.BerkeleyDB/Todo
BitKeeper/deleted/.del-config.in~ae81681e450e0999:
Delete: bdb/perl.BerkeleyDB/config.in
BitKeeper/deleted/.del-dbinfo~28ad67d83be4f68e:
Delete: bdb/perl.BerkeleyDB/dbinfo
BitKeeper/deleted/.del-mkconsts~543ab60669c7a04e:
Delete: bdb/perl.BerkeleyDB/mkconsts
BitKeeper/deleted/.del-mkpod~182c0ca54e439afb:
Delete: bdb/perl.BerkeleyDB/mkpod
BitKeeper/deleted/.del-5.004~e008cb5a48805543:
Delete: bdb/perl.BerkeleyDB/patches/5.004
BitKeeper/deleted/.del-irix_6_5.pl~61662bb08afcdec8:
Delete: bdb/perl.BerkeleyDB/hints/irix_6_5.pl
BitKeeper/deleted/.del-solaris.pl~6771e7182394e152:
Delete: bdb/perl.BerkeleyDB/hints/solaris.pl
BitKeeper/deleted/.del-typemap~783b8f5295b05f3d:
Delete: bdb/perl.BerkeleyDB/typemap
BitKeeper/deleted/.del-5.004_01~6081ce2fff7b0bc:
Delete: bdb/perl.BerkeleyDB/patches/5.004_01
BitKeeper/deleted/.del-5.004_02~87214eac35ad9e6:
Delete: bdb/perl.BerkeleyDB/patches/5.004_02
BitKeeper/deleted/.del-5.004_03~9a672becec7cb40f:
Delete: bdb/perl.BerkeleyDB/patches/5.004_03
BitKeeper/deleted/.del-5.004_04~e326cb51af09d154:
Delete: bdb/perl.BerkeleyDB/patches/5.004_04
BitKeeper/deleted/.del-5.004_05~7ab457a1e41a92fe:
Delete: bdb/perl.BerkeleyDB/patches/5.004_05
BitKeeper/deleted/.del-5.005~f9e2d59b5964cd4b:
Delete: bdb/perl.BerkeleyDB/patches/5.005
BitKeeper/deleted/.del-5.005_01~3eb9fb7b5842ea8e:
Delete: bdb/perl.BerkeleyDB/patches/5.005_01
BitKeeper/deleted/.del-5.005_02~67477ce0bef717cb:
Delete: bdb/perl.BerkeleyDB/patches/5.005_02
BitKeeper/deleted/.del-5.005_03~c4c29a1fb21e290a:
Delete: bdb/perl.BerkeleyDB/patches/5.005_03
BitKeeper/deleted/.del-5.6.0~e1fb9897d124ee22:
Delete: bdb/perl.BerkeleyDB/patches/5.6.0
BitKeeper/deleted/.del-btree.t~e4a1a3c675ddc406:
Delete: bdb/perl.BerkeleyDB/t/btree.t
BitKeeper/deleted/.del-db-3.0.t~d2c60991d84558f2:
Delete: bdb/perl.BerkeleyDB/t/db-3.0.t
BitKeeper/deleted/.del-db-3.1.t~6ee88cd13f55e018:
Delete: bdb/perl.BerkeleyDB/t/db-3.1.t
BitKeeper/deleted/.del-db-3.2.t~f73b6461f98fd1cf:
Delete: bdb/perl.BerkeleyDB/t/db-3.2.t
BitKeeper/deleted/.del-destroy.t~cc6a2ae1980a2ecd:
Delete: bdb/perl.BerkeleyDB/t/destroy.t
BitKeeper/deleted/.del-env.t~a8604a4499c4bd07:
Delete: bdb/perl.BerkeleyDB/t/env.t
BitKeeper/deleted/.del-examples.t~2571b77c3cc75574:
Delete: bdb/perl.BerkeleyDB/t/examples.t
BitKeeper/deleted/.del-examples.t.T~8228bdd75ac78b88:
Delete: bdb/perl.BerkeleyDB/t/examples.t.T
BitKeeper/deleted/.del-examples3.t.T~66a186897a87026d:
Delete: bdb/perl.BerkeleyDB/t/examples3.t.T
BitKeeper/deleted/.del-examples3.t~fe3822ba2f2d7f83:
Delete: bdb/perl.BerkeleyDB/t/examples3.t
BitKeeper/deleted/.del-filter.t~f87b045c1b708637:
Delete: bdb/perl.BerkeleyDB/t/filter.t
BitKeeper/deleted/.del-hash.t~616bfb4d644de3a3:
Delete: bdb/perl.BerkeleyDB/t/hash.t
BitKeeper/deleted/.del-join.t~29fc39f74a83ca22:
Delete: bdb/perl.BerkeleyDB/t/join.t
BitKeeper/deleted/.del-mldbm.t~31f5015341eea040:
Delete: bdb/perl.BerkeleyDB/t/mldbm.t
BitKeeper/deleted/.del-queue.t~8f338034ce44a641:
Delete: bdb/perl.BerkeleyDB/t/queue.t
BitKeeper/deleted/.del-recno.t~d4ddbd3743add63e:
Delete: bdb/perl.BerkeleyDB/t/recno.t
BitKeeper/deleted/.del-strict.t~6885cdd2ea71ca2d:
Delete: bdb/perl.BerkeleyDB/t/strict.t
BitKeeper/deleted/.del-subdb.t~aab62a5d5864c603:
Delete: bdb/perl.BerkeleyDB/t/subdb.t
BitKeeper/deleted/.del-txn.t~65033b8558ae1216:
Delete: bdb/perl.BerkeleyDB/t/txn.t
BitKeeper/deleted/.del-unknown.t~f3710458682665e1:
Delete: bdb/perl.BerkeleyDB/t/unknown.t
BitKeeper/deleted/.del-Changes~436f74a5c414c65b:
Delete: bdb/perl.DB_File/Changes
BitKeeper/deleted/.del-DB_File.pm~ae0951c6c7665a82:
Delete: bdb/perl.DB_File/DB_File.pm
BitKeeper/deleted/.del-DB_File.xs~89e49a0b5556f1d8:
Delete: bdb/perl.DB_File/DB_File.xs
BitKeeper/deleted/.del-DB_File_BS~290fad5dbbb87069:
Delete: bdb/perl.DB_File/DB_File_BS
BitKeeper/deleted/.del-MANIFEST~90ee581572bdd4ac:
Delete: bdb/perl.DB_File/MANIFEST
BitKeeper/deleted/.del-Makefile.PL~ac0567bb5a377e38:
Delete: bdb/perl.DB_File/Makefile.PL
BitKeeper/deleted/.del-README~77e924a5a9bae6b3:
Delete: bdb/perl.DB_File/README
BitKeeper/deleted/.del-config.in~ab4c2792b86a810b:
Delete: bdb/perl.DB_File/config.in
BitKeeper/deleted/.del-dbinfo~461c43b30fab2cb:
Delete: bdb/perl.DB_File/dbinfo
BitKeeper/deleted/.del-dynixptx.pl~50dcddfae25d17e9:
Delete: bdb/perl.DB_File/hints/dynixptx.pl
BitKeeper/deleted/.del-typemap~55cffb3288a9e587:
Delete: bdb/perl.DB_File/typemap
BitKeeper/deleted/.del-version.c~a4df0e646f8b3975:
Delete: bdb/perl.DB_File/version.c
BitKeeper/deleted/.del-5.004_01~d6830d0082702af7:
Delete: bdb/perl.DB_File/patches/5.004_01
BitKeeper/deleted/.del-5.004_02~78b082dc80c91031:
Delete: bdb/perl.DB_File/patches/5.004_02
BitKeeper/deleted/.del-5.004~4411ec2e3c9e008b:
Delete: bdb/perl.DB_File/patches/5.004
BitKeeper/deleted/.del-sco.pl~1e795fe14fe4dcfe:
Delete: bdb/perl.DB_File/hints/sco.pl
BitKeeper/deleted/.del-5.004_03~33f274648b160d95:
Delete: bdb/perl.DB_File/patches/5.004_03
BitKeeper/deleted/.del-5.004_04~8f3d1b3cf18bb20a:
Delete: bdb/perl.DB_File/patches/5.004_04
BitKeeper/deleted/.del-5.004_05~9c0f02e7331e142:
Delete: bdb/perl.DB_File/patches/5.004_05
BitKeeper/deleted/.del-5.005~c2108cb2e3c8d951:
Delete: bdb/perl.DB_File/patches/5.005
BitKeeper/deleted/.del-5.005_01~3b45e9673afc4cfa:
Delete: bdb/perl.DB_File/patches/5.005_01
BitKeeper/deleted/.del-5.005_02~9fe5766bb02a4522:
Delete: bdb/perl.DB_File/patches/5.005_02
BitKeeper/deleted/.del-5.005_03~ffa1c38c19ae72ea:
Delete: bdb/perl.DB_File/patches/5.005_03
BitKeeper/deleted/.del-5.6.0~373be3a5ce47be85:
Delete: bdb/perl.DB_File/patches/5.6.0
BitKeeper/deleted/.del-db-btree.t~3231595a1c241eb3:
Delete: bdb/perl.DB_File/t/db-btree.t
BitKeeper/deleted/.del-db-hash.t~7c4ad0c795c7fad2:
Delete: bdb/perl.DB_File/t/db-hash.t
BitKeeper/deleted/.del-db-recno.t~6c2d3d80b9ba4a50:
Delete: bdb/perl.DB_File/t/db-recno.t
BitKeeper/deleted/.del-db_server.sed~cdb00ebcd48a64e2:
Delete: bdb/rpc_server/db_server.sed
BitKeeper/deleted/.del-db_server_proc.c~d46c8f409c3747f4:
Delete: bdb/rpc_server/db_server_proc.c
BitKeeper/deleted/.del-db_server_svc.sed~3f5e59f334fa4607:
Delete: bdb/rpc_server/db_server_svc.sed
BitKeeper/deleted/.del-db_server_util.c~a809f3a4629acda:
Delete: bdb/rpc_server/db_server_util.c
BitKeeper/deleted/.del-log.tcl~ff1b41f1355b97d7:
Delete: bdb/test/log.tcl
BitKeeper/deleted/.del-mpool.tcl~b0df4dc1b04db26c:
Delete: bdb/test/mpool.tcl
BitKeeper/deleted/.del-mutex.tcl~52fd5c73a150565:
Delete: bdb/test/mutex.tcl
BitKeeper/deleted/.del-txn.tcl~c4ff071550b5446e:
Delete: bdb/test/txn.tcl
BitKeeper/deleted/.del-README~e800a12a5392010a:
Delete: bdb/test/upgrade/README
BitKeeper/deleted/.del-pack-2.6.6.pl~89d5076d758d3e98:
Delete: bdb/test/upgrade/generate-2.X/pack-2.6.6.pl
BitKeeper/deleted/.del-test-2.6.patch~4a52dc83d447547b:
Delete: bdb/test/upgrade/generate-2.X/test-2.6.patch
Diffstat (limited to 'bdb/perl/DB_File')
30 files changed, 12957 insertions, 0 deletions
diff --git a/bdb/perl/DB_File/Changes b/bdb/perl/DB_File/Changes new file mode 100644 index 00000000000..7883cbdfef0 --- /dev/null +++ b/bdb/perl/DB_File/Changes @@ -0,0 +1,434 @@ + +1.805 1st September 2002 + + * Added support to allow DB_File to build with Berkeley DB 4.1.X + + * Tightened up the test harness to test that calls to untie don't generate + the "untie attempted while %d inner references still exist" warning. + + * added code to guard against calling the callbacks (compare,hash & prefix) + recursively. + + * pasing undef for the flags and/or mode when opening a database could cause + a "Use of uninitialized value in subroutine entry" warning. Now silenced. + + * DBM filter code beefed up to cope with read-only $_. + +1.804 2nd June 2002 + + * Perl core patch 14939 added a new warning to "splice". This broke the + db-recno test harness. Fixed. + + * merged core patches 16502 & 16540. + +1.803 1st March 2002 + + * Fixed a problem with db-btree.t where it complained about an "our" + variable redeclaation. + + * FETCH, STORE & DELETE don't map the flags parameter into the + equivalent Berkeley DB function anymore. + +1.802 6th January 2002 + + * The message about some test failing in db-recno.t had the wrong test + numbers. Fixed. + + * merged core patch 13942. + +1.801 26th November 2001 + + * Fixed typo in Makefile.PL + + * Added "clean" attribute to Makefile.PL + +1.800 23rd November 2001 + + * use pport.h for perl backward compatability code. + + * use new ExtUtils::Constant module to generate XS constants. + + * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with + "use vars" + +1.79 22nd October 2001 + + * Added a "local $SIG{__DIE__}" inside the eval that checks for + the presence of XSLoader s suggested by Andrew Hryckowin. + + * merged core patch 12277. + + * Changed NEXTKEY to not initialise the input key. It isn't used anyway. + +1.79 22nd October 2001 + + * Fixed test harness for cygwin + +1.78 30th July 2001 + + * the test in Makefile.PL for AIX used -plthreads. Should have been + -lpthreads + + * merged Core patches + 10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432 + + * added documentation patch regarding duplicate keys from Andrew Johnson + + +1.77 26th April 2001 + + * AIX is reported to need -lpthreads, so Makefile.PL now checks for + AIX and adds it to the link options. + + * Minor documentation updates. + + * Merged Core patch 9176 + + * Added a patch from Edward Avis that adds support for splice with + recno databases. + + * Modified Makefile.PL to only enable the warnings pragma if using perl + 5.6.1 or better. + +1.76 15th January 2001 + + * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work + with DB_File on Linux. Thanks to Norbert Bollow for sending details of + this approach. + + +1.75 17th December 2000 + + * Fixed perl core patch 7703 + + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. + +1.73 31st May 2000 + + * Added support in version.c for building with threaded Perl. + + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.72 16th January 2000 + + * Added hints/sco.pl + + * The module will now use XSLoader when it is available. When it + isn't it will use DynaLoader. + + * The locking section in DB_File.pm has been discredited. Many thanks + to David Harris for spotting the underlying problem, contributing + the updates to the documentation and writing DB_File::Lock (available + on CPAN). + +1.71 7th September 1999 + + * Fixed a bug that prevented 1.70 from compiling under win32 + + * Updated to support Berkeley DB 3.x + + * Updated dbinfo for Berkeley DB 3.x file formats. + +1.70 4th August 1999 + + * Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + + * Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + +1.69 3rd August 1999 + + * fixed a bug in push -- DB_APPEND wasn't working properly. + + * Fixed the R_SETCURSOR bug introduced in 1.68 + + * Added a new Perl variable $DB_File::db_ver + +1.68 22nd July 1999 + + * Merged changes from 5.005_58 + + * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB + 2 databases. + + * Added some of the examples in the POD into the test harness. + +1.67 6th June 1999 + + * Added DBM Filter documentation to DB_File.pm + + * Fixed DBM Filter code to work with 5.004 + + * A few instances of newSVpvn were used in 1.66. This isn't available in + Perl 5.004_04 or earlier. Replaced with newSVpv. + +1.66 15th March 1999 + + * Added DBM Filter code + +1.65 6th March 1999 + + * Fixed a bug in the recno PUSH logic. + * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 + +1.64 21st February 1999 + + * Tidied the 1.x to 2.x flag mapping code. + * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag + mapping problem with O_RDONLY on the Hurd + * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. + +1.63 19th December 1998 + + * Fix to allow DB 2.6.x to build with DB_File + * Documentation updated to use push,pop etc in the RECNO example & + to include the find_dup & del_dup methods. + +1.62 30th November 1998 + + Added hints/dynixptx.pl. + Fixed typemap -- 1.61 used PL_na instead of na + +1.61 19th November 1998 + + Added a note to README about how to build Berkeley DB 2.x when + using HP-UX. + Minor modifications to get the module to build with DB 2.5.x + Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. + +1.60 + Changed the test to check for full tied array support + +1.59 + Updated the license section. + + Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in + db-btree.t and test 27 in db-hash.t failed because of this change. + Those tests have been zapped. + + Added dbinfo to the distribution. + +1.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + + Fixed a problem with the use of sv_setpvn. When the size is + specified as 0, it does a strlen on the data. This was ok for DB + 1.x, but isn't for DB 2.x. + +1.57 + If Perl has been compiled with Threads support,the symbol op will be + defined. This clashes with a field name in db.h, so it needs to be + #undef'ed before db.h is included. + +1.56 + Documented the Solaris 2.5 mutex bug + +1.55 + Merged 1.16 changes. + +1.54 + + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. + +1.53 + + Added DB_RENUMBER to flags for recno. + +1.52 + + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. + +1.51 + + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. + + + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + +1.50 + + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. + +1.16 + + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + + Small fix for the AIX strict C compiler XLC which doesn't like + __attribute__ being defined via proto.h and redefined via db.h. Fix + courtesy of Jarkko Hietaniemi. + +1.15 + + Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the + O_* constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now + DB_File creats objects in the namespace of the package it has been + inherited into. + + +1.14 + + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. + +1.13 + + Minor changes to DB_FIle.xs and DB_File.pm + +1.12 + + Documented the incompatibility with version 2 of Berkeley DB. + +1.11 + + Documented the untie gotcha. + +1.10 + + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. + +1.09 + + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. + + Changed default mode to 0666. + +1.08 + + Documented operation of bval. + +1.07 + + Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +1.06 + + Minor namespace cleanup: Localized PrintBtree. + +1.05 + + Made all scripts in the documentation strict and -w clean. + + Added logic to DB_File.xs to allow the module to be built after + Perl is installed. + +1.04 + + Minor documentation changes. + + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + <hammen@gothamcity.jsc.nasa.govt>. + + Fixed a bug with the constructors for DB_File::HASHINFO, + DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the + constructors to make them -w clean. + + Reworked part of the test harness to be more locale friendly. + +1.03 + + Documentation update. + + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. + + The standard hash function exists is now supported. + + Modified the behavior of get_dup. When it returns an associative + array, the value is the count of the number of matching BTREE + values. + +1.02 + + Merged OS/2 specific code into DB_File.xs + + Removed some redundant code in DB_File.xs. + + Documentation update. + + Allow negative subscripts with RECNO interface. + + Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + + The example code which showed how to lock a database needed a call + to sync added. Without it the resultant database file was empty. + + Added get_dup method. + +1.01 + + Fixed a core dump problem with SunOS. + + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. + +1.0 + + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. + + Added complete support for multiple concurrent callbacks. + + Using the push method on an empty list didn't work properly. This + has been fixed. + +0.3 + + Added prototype support for multiple btree compare callbacks. + +0.2 + + When DB_File is opening a database file it no longer terminates the + process if dbopen returned an error. This allows file protection + errors to be caught at run time. Thanks to Judith Grass + <grass@cybercash.com> for spotting the bug. + +0.1 + + First Release. + diff --git a/bdb/perl/DB_File/DB_File.pm b/bdb/perl/DB_File/DB_File.pm new file mode 100644 index 00000000000..49004ffa148 --- /dev/null +++ b/bdb/perl/DB_File/DB_File.pm @@ -0,0 +1,2291 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (Paul.Marquess@btinternet.com) +# last modified 1st September 2002 +# version 1.805 +# +# Copyright (c) 1995-2002 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + + +package DB_File::HASHINFO ; + +require 5.00404; + +use warnings; +use strict; +use Carp; +require Tie::Hash; +@DB_File::HASHINFO::ISA = qw(Tie::Hash); + +sub new +{ + my $pkg = shift ; + my %x ; + tie %x, $pkg ; + bless \%x, $pkg ; +} + + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { + bsize => 1, + ffactor => 1, + nelem => 1, + cachesize => 1, + hash => 2, + lorder => 1, + }, + GOT => {} + }, $pkg ; +} + + +sub FETCH +{ + my $self = shift ; + my $key = shift ; + + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; + + my $pkg = ref $self ; + croak "${pkg}::FETCH - Unknown element '$key'" ; +} + + +sub STORE +{ + my $self = shift ; + my $key = shift ; + my $value = shift ; + + my $type = $self->{VALID}{$key}; + + if ( $type ) + { + croak "Key '$key' not associated with a code reference" + if $type == 2 && !ref $value && ref $value ne 'CODE'; + $self->{GOT}{$key} = $value ; + return ; + } + + my $pkg = ref $self ; + croak "${pkg}::STORE - Unknown element '$key'" ; +} + +sub DELETE +{ + my $self = shift ; + my $key = shift ; + + if ( exists $self->{VALID}{$key} ) + { + delete $self->{GOT}{$key} ; + return ; + } + + my $pkg = ref $self ; + croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; +} + +sub EXISTS +{ + my $self = shift ; + my $key = shift ; + + exists $self->{VALID}{$key} ; +} + +sub NotHere +{ + my $self = shift ; + my $method = shift ; + + croak ref($self) . " does not define the method ${method}" ; +} + +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } + +package DB_File::RECNOINFO ; + +use warnings; +use strict ; + +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; +} + +package DB_File::BTREEINFO ; + +use warnings; +use strict ; + +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { + flags => 1, + cachesize => 1, + maxkeypage => 1, + minkeypage => 1, + psize => 1, + compare => 2, + prefix => 2, + lorder => 1, + }, + GOT => {}, + }, $pkg ; +} + + +package DB_File ; + +use warnings; +use strict; +our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO); +our ($db_version, $use_XSLoader, $splice_end_array); +use Carp; + + +$VERSION = "1.805" ; + +{ + local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; + my @a =(1); splice(@a, 3); + $splice_end_array = + ($splice_end_array =~ /^splice\(\) offset past end of array at /); +} + +#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; +$DB_BTREE = new DB_File::BTREEINFO ; +$DB_HASH = new DB_File::HASHINFO ; +$DB_RECNO = new DB_File::RECNOINFO ; + +require Tie::Hash; +require Exporter; +use AutoLoader; +BEGIN { + $use_XSLoader = 1 ; + { local $SIG{__DIE__} ; eval { require XSLoader } ; } + + if ($@) { + $use_XSLoader = 0 ; + require DynaLoader; + @ISA = qw(DynaLoader); + } +} + +push @ISA, qw(Tie::Hash Exporter); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + +); + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + my ($error, $val) = constant($constname); + Carp::croak $error if $error; + no strict 'refs'; + *{$AUTOLOAD} = sub { $val }; + goto &{$AUTOLOAD}; +} + + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +if ($use_XSLoader) + { XSLoader::load("DB_File", $VERSION)} +else + { bootstrap DB_File $VERSION } + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; + $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; + + # make recno in Berkeley DB version 2 work like recno in version 1. + if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and + $arg[1] and ! -e $arg[1]) { + open(FH, ">$arg[1]") or return undef ; + close FH ; + chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; + } + + DoTie_($tieHASH, @arg) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub CLEAR +{ + my $self = shift; + my $key = 0 ; + my $value = "" ; + my $status = $self->seq($key, $value, R_FIRST()); + my @keys; + + while ($status == 0) { + push @keys, $key; + $status = $self->seq($key, $value, R_NEXT()); + } + foreach $key (reverse @keys) { + my $s = $self->del($key); + } +} + +sub EXTEND { } + +sub STORESIZE +{ + my $self = shift; + my $length = shift ; + my $current_length = $self->length() ; + + if ($length < $current_length) { + my $key ; + for ($key = $current_length - 1 ; $key >= $length ; -- $key) + { $self->del($key) } + } + elsif ($length > $current_length) { + $self->put($length-1, "") ; + } +} + + +sub SPLICE +{ + my $self = shift; + my $offset = shift; + if (not defined $offset) { + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $offset = 0; + } + + my $length = @_ ? shift : 0; + # Carping about definedness comes _after_ the OFFSET sanity check. + # This is so we get the same error messages as Perl's splice(). + # + + my @list = @_; + + my $size = $self->FETCHSIZE(); + + # 'If OFFSET is negative then it start that far from the end of + # the array.' + # + if ($offset < 0) { + my $new_offset = $size + $offset; + if ($new_offset < 0) { + die "Modification of non-creatable array value attempted, " + . "subscript $offset"; + } + $offset = $new_offset; + } + + if (not defined $length) { + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $length = 0; + } + + if ($offset > $size) { + $offset = $size; + warnings::warnif('misc', 'splice() offset past end of array') + if $splice_end_array; + } + + # 'If LENGTH is omitted, removes everything from OFFSET onward.' + if (not defined $length) { + $length = $size - $offset; + } + + # 'If LENGTH is negative, leave that many elements off the end of + # the array.' + # + if ($length < 0) { + $length = $size - $offset + $length; + + if ($length < 0) { + # The user must have specified a length bigger than the + # length of the array passed in. But perl's splice() + # doesn't catch this, it just behaves as for length=0. + # + $length = 0; + } + } + + if ($length > $size - $offset) { + $length = $size - $offset; + } + + # $num_elems holds the current number of elements in the database. + my $num_elems = $size; + + # 'Removes the elements designated by OFFSET and LENGTH from an + # array,'... + # + my @removed = (); + foreach (0 .. $length - 1) { + my $old; + my $status = $self->get($offset, $old); + if ($status != 0) { + my $msg = "error from Berkeley DB on get($offset, \$old)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + push @removed, $old; + + $status = $self->del($offset); + if ($status != 0) { + my $msg = "error from Berkeley DB on del($offset)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + -- $num_elems; + } + + # ...'and replaces them with the elements of LIST, if any.' + my $pos = $offset; + while (defined (my $elem = shift @list)) { + my $old_pos = $pos; + my $status; + if ($pos >= $num_elems) { + $status = $self->put($pos, $elem); + } + else { + $status = $self->put($pos, $elem, $self->R_IBEFORE); + } + + if ($status != 0) { + my $msg = "error from Berkeley DB on put($pos, $elem, ...)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ", error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE" + if $old_pos != $pos; + + ++ $pos; + ++ $num_elems; + } + + if (wantarray) { + # 'In list context, returns the elements removed from the + # array.' + # + return @removed; + } + elsif (defined wantarray and not wantarray) { + # 'In scalar context, returns the last element removed, or + # undef if no elements are removed.' + # + if (@removed) { + my $last = pop @removed; + return "$last"; + } + else { + return undef; + } + } + elsif (not defined wantarray) { + # Void context + } + else { die } +} +sub ::DB_File::splice { &SPLICE } + +sub find_dup +{ + croak "Usage: \$db->find_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($origkey, $value_wanted) = @_ ; + my ($key, $value) = ($origkey, 0); + my ($status) = 0 ; + + for ($status = $db->seq($key, $value, R_CURSOR() ) ; + $status == 0 ; + $status = $db->seq($key, $value, R_NEXT() ) ) { + + return 0 if $key eq $origkey and $value eq $value_wanted ; + } + + return $status ; +} + +sub del_dup +{ + croak "Usage: \$db->del_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($key, $value) = @_ ; + my ($status) = $db->find_dup($key, $value) ; + return $status if $status != 0 ; + + $status = $db->del($key, R_CURSOR() ) ; + return $status ; +} + +sub get_dup +{ + croak "Usage: \$db->get_dup(key [,flag])\n" + unless @_ == 2 or @_ == 3 ; + + my $db = shift ; + my $key = shift ; + my $flag = shift ; + my $value = 0 ; + my $origkey = $key ; + my $wantarray = wantarray ; + my %values = () ; + my @values = () ; + my $counter = 0 ; + my $status = 0 ; + + # iterate through the database until either EOF ($status == 0) + # or a different key is encountered ($key ne $origkey). + for ($status = $db->seq($key, $value, R_CURSOR()) ; + $status == 0 and $key eq $origkey ; + $status = $db->seq($key, $value, R_NEXT()) ) { + + # save the value or count number of matches + if ($wantarray) { + if ($flag) + { ++ $values{$value} } + else + { push (@values, $value) } + } + else + { ++ $counter } + + } + + return ($wantarray ? ($flag ? %values : @values) : $counter) ; +} + + +1; +__END__ + +=head1 NAME + +DB_File - Perl5 access to Berkeley DB version 1.x + +=head1 SYNOPSIS + + use DB_File; + + [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; + + $status = $X->del($key [, $flags]) ; + $status = $X->put($key, $value [, $flags]) ; + $status = $X->get($key, $value [, $flags]) ; + $status = $X->seq($key, $value, $flags) ; + $status = $X->sync([$flags]) ; + $status = $X->fd ; + + # BTREE only + $count = $X->get_dup($key) ; + @list = $X->get_dup($key) ; + %list = $X->get_dup($key, 1) ; + $status = $X->find_dup($key, $value) ; + $status = $X->del_dup($key, $value) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + @r = $X->splice(offset, length, elements); + + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + + untie %hash ; + untie @array ; + +=head1 DESCRIPTION + +B<DB_File> is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1.x (if you have a newer +version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>). +It is assumed that you have a copy of the Berkeley DB manual pages at +hand when reading this documentation. The interface defined here +mirrors the Berkeley DB interface closely. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. B<DB_File> provides an interface to all +three of the database types currently supported by Berkeley DB. + +The file types are: + +=over 5 + +=item B<DB_HASH> + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using DB_HASH are not compatible with any of the +other packages mentioned. + +A default hashing algorithm, which will be adequate for most +applications, is built into Berkeley DB. If you do need to use your own +hashing algorithm it is possible to write your own in Perl and have +B<DB_File> use it instead. + +=item B<DB_BTREE> + +The btree format allows arbitrary key/value pairs to be stored in a +sorted, balanced binary tree. + +As with the DB_HASH format, it is possible to provide a user defined +Perl routine to perform the comparison of keys. By default, though, the +keys are stored in lexical order. + +=item B<DB_RECNO> + +DB_RECNO allows both fixed-length and variable-length flat text files +to be manipulated using the same key/value pair interface as in DB_HASH +and DB_BTREE. In this case the key will consist of a record (line) +number. + +=back + +=head2 Using DB_File with Berkeley DB version 2 or greater + +Although B<DB_File> is intended to be used with Berkeley DB version 1, +it can also be used with version 2, 3 or 4. In this case the interface is +limited to the functionality provided by Berkeley DB 1.x. Anywhere the +version 2 or greater interface differs, B<DB_File> arranges for it to work +like version 1. This feature allows B<DB_File> scripts that were built +with version 1 to be migrated to version 2 or greater without any changes. + +If you want to make use of the new features available in Berkeley DB +2.x or greater, use the Perl module B<BerkeleyDB> instead. + +B<Note:> The database file format has changed multiple times in Berkeley +DB version 2, 3 and 4. If you cannot recreate your databases, you +must dump any existing databases with either the C<db_dump> or the +C<db_dump185> utility that comes with Berkeley DB. +Once you have rebuilt DB_File to use Berkeley DB version 2 or greater, +your databases can be recreated using C<db_load>. Refer to the Berkeley DB +documentation for further details. + +Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley +DB with DB_File. + +=head2 Interface to Berkeley DB + +B<DB_File> allows access to Berkeley DB files using the tie() mechanism +in Perl 5 (for full details, see L<perlfunc/tie()>). This facility +allows B<DB_File> to access Berkeley DB files using either an +associative array (for DB_HASH & DB_BTREE file types) or an ordinary +array (for the DB_RECNO file type). + +In addition to the tie() interface, it is also possible to access most +of the functions provided in the Berkeley DB API directly. +See L<THE API INTERFACE>. + +=head2 Opening a Berkeley DB Database File + +Berkeley DB uses the function dbopen() to open or create a database. +Here is the C prototype for dbopen(): + + DB* + dbopen (const char * file, int flags, int mode, + DBTYPE type, const void * openinfo) + +The parameter C<type> is an enumeration which specifies which of the 3 +interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. +Depending on which of these is actually chosen, the final parameter, +I<openinfo> points to a data structure which allows tailoring of the +specific interface method. + +This interface is handled slightly differently in B<DB_File>. Here is +an equivalent call using B<DB_File>: + + tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; + +The C<filename>, C<flags> and C<mode> parameters are the direct +equivalent of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C<type> and C<openinfo> parameters in +dbopen(). + +In the example above $DB_HASH is actually a pre-defined reference to a +hash object. B<DB_File> has three of these pre-defined references. +Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. + +The keys allowed in each of these pre-defined references is limited to +the names used in the equivalent C structure. So, for example, the +$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, +C<ffactor>, C<hash>, C<lorder> and C<nelem>. + +To change one of these elements, just assign to it like this: + + $DB_HASH->{'cachesize'} = 10000 ; + +The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are +usually adequate for most applications. If you do need to create extra +instances of these objects, constructors are available for each file +type. + +Here are examples of the constructors and the valid options available +for DB_HASH, DB_BTREE and DB_RECNO respectively. + + $a = new DB_File::HASHINFO ; + $a->{'bsize'} ; + $a->{'cachesize'} ; + $a->{'ffactor'}; + $a->{'hash'} ; + $a->{'lorder'} ; + $a->{'nelem'} ; + + $b = new DB_File::BTREEINFO ; + $b->{'flags'} ; + $b->{'cachesize'} ; + $b->{'maxkeypage'} ; + $b->{'minkeypage'} ; + $b->{'psize'} ; + $b->{'compare'} ; + $b->{'prefix'} ; + $b->{'lorder'} ; + + $c = new DB_File::RECNOINFO ; + $c->{'bval'} ; + $c->{'cachesize'} ; + $c->{'psize'} ; + $c->{'flags'} ; + $c->{'lorder'} ; + $c->{'reclen'} ; + $c->{'bfname'} ; + +The values stored in the hashes above are mostly the direct equivalent +of their C counterpart. Like their C counterparts, all are set to a +default values - that means you don't have to set I<all> of the +values when you only want to change one. Here is an example: + + $a = new DB_File::HASHINFO ; + $a->{'cachesize'} = 12345 ; + tie %y, 'DB_File', "filename", $flags, 0777, $a ; + +A few of the options need extra discussion here. When used, the C +equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers +to C functions. In B<DB_File> these keys are used to store references +to Perl subs. Below are templates for each of the subs: + + sub hash + { + my ($data) = @_ ; + ... + # return the hash value for $data + return $hash ; + } + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + +See L<Changing the BTREE sort order> for an example of using the +C<compare> template. + +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The 'bval' Option>. + +=head2 Default Parameters + +It is possible to omit some or all of the final 4 parameters in the +call to C<tie> and let them take default values. As DB_HASH is the most +common file format used, the call: + + tie %A, "DB_File", "filename" ; + +is equivalent to: + + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; + +It is also possible to omit the filename parameter as well, so the +call: + + tie %A, "DB_File" ; + +is equivalent to: + + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; + +See L<In Memory Databases> for a discussion on the use of C<undef> +in place of a filename. + +=head2 In Memory Databases + +Berkeley DB allows the creation of in-memory databases by using NULL +(that is, a C<(char *)0> in C) in place of the filename. B<DB_File> +uses C<undef> instead of NULL to provide this functionality. + +=head1 DB_HASH + +The DB_HASH file format is probably the most commonly used of the three +file formats that B<DB_File> supports. It is also very straightforward +to use. + +=head2 A Simple Example + +This example shows how to create a database, add key/value pairs to the +database, delete keys/value pairs and finally how to enumerate the +contents of the database. + + use warnings ; + use strict ; + use DB_File ; + our (%h, $k, $v) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +This script shows how to override the default sorting algorithm that +BTREE uses. Instead of using the normal lexical ordering, a case +insensitive compare function will be used. + + use warnings ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=item 3 + +Duplicate keys are entirely defined by the comparison function. +In the case-insensitive example above, the keys: 'KEY' and 'key' +would be considered duplicates, and assigning to the second one +would overwrite the first. If duplicates are allowed for (with the +R_DUPS flag discussed below), only a single copy of duplicate keys +is stored in the database --- so (again with example above) assigning +three values to the keys: 'KEY', 'Key', and 'key' would leave just +the first key: 'KEY' in the database with three values. For some +situations this results in information loss, so care should be taken +to provide fully qualified comparison functions when necessary. +For example, the above comparison routine could be modified to +additionally compare case-sensitively if two keys are equal in the +case insensitive comparison: + + sub compare { + my($key1, $key2) = @_; + lc $key1 cmp lc $key2 || + $key1 cmp $key2; + } + +And now you will only have duplicates when the keys themselves +are truly the same. (note: in versions of the db library prior to +about November 1996, such duplicate keys were retained so it was +possible to recover the original keys in sets of keys that +compared as equal). + + +=back + +=head2 Handling Duplicate Keys + +The BTREE file type optionally allows a single key to be associated +with an arbitrary number of values. This option is enabled by setting +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +There are some difficulties in using the tied hash interface if you +want to manipulate a BTREE database with duplicate keys. Consider this +code: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, %h) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (sort keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C<Wall> +- the only thing is, when they are retrieved from the database they +I<seem> to have the same value, namely C<Larry>. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C<seq>. This method allows sequential access to key/value +pairs. See L<THE API INTERFACE> for details of both the C<seq> method +and the API in general. + +Here is the script above rewritten using the C<seq> API method. + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $status, $key, $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C<Wall>. + +To make life easier when dealing with duplicate keys, B<DB_File> comes with +a few utility methods. + +=head2 The get_dup() Method + +The C<get_dup> method assists in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C<get_dup> like +this: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + +and it will print: + + Wall occurred 3 times + Larry is there + There are 2 Brick Walls + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] + +=head2 The find_dup() Method + + $status = $X->find_dup($key, $value) ; + +This method checks for the existence of a specific key/value pair. If the +pair exists, the cursor is left pointing to the pair and the method +returns 0. Otherwise the method returns a non-zero value. + +Assuming the database from the previous example: + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is there + Harry Wall is not there + + +=head2 The del_dup() Method + + $status = $X->del_dup($key, $value) ; + +This method deletes a specific key/value pair. It returns +0 if they exist and have been deleted successfully. +Otherwise the method returns a non-zero value. + +Again assuming the existence of the C<tree> database + + use warnings ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is not there + +=head2 Matching Partial Keys + +The BTREE interface has a feature which allows partial keys to be +matched. This functionality is I<only> available when the C<seq> method +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +Here is the relevant quote from the dbopen man page where it defines +the use of the R_CURSOR flag with seq: + + Note, for the DB_BTREE access method, the returned key is not + necessarily an exact match for the specified key. The returned key + is the smallest key greater than or equal to the specified key, + permitting partial key matches and range searches. + +In the example script below, the C<match> sub uses this feature to find +and print the first matching key/value pair given a partial key. + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($filename, $x, %h, $st, $key, $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl, the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms to it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + +Also note that the bval option only allows you to specify a single byte +as a delimeter. + +=head2 A Simple Example + +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). + + use warnings ; + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + The array contains 5 entries + popped black + shifted white + Element 1 Exists with value blue + The last element is green + The 2nd last element is yellow + +=head2 Extra RECNO Methods + +If you are using a version of Perl earlier than 5.004_57, the tied +array interface is quite limited. In the example script above +C<push>, C<pop>, C<shift>, C<unshift> +or determining the array length will not work with a tied array. + +To make the interface more useful for older versions of Perl, a number +of methods are supplied with B<DB_File> to simulate the missing array +operations. All these methods are accessed via the object returned from +the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-E<gt>push(list) ;> + +Pushes the elements of C<list> to the end of the array. + +=item B<$value = $X-E<gt>pop ;> + +Removes and returns the last element of the array. + +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> + +Pushes the elements of C<list> to the start of the array. + +=item B<$X-E<gt>length> + +Returns the number of elements in the array. + +=item B<$X-E<gt>splice(offset, length, elements);> + +Returns a splice of the the array. + +=back + +=head2 Another Example + +Here is a more complete example that makes use of some of the methods +described above. It also makes use of the API interface directly (see +L<THE API INTERFACE>). + + use warnings ; + use strict ; + my (@h, $H, $file, $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C<put> method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C<put> will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE + +As well as accessing Berkeley DB using a tied hash or array, it is also +possible to make direct use of most of the API functions defined in the +Berkeley DB documentation. + +To do this you need to store a copy of the object returned from the tie. + + $db = tie %hash, "DB_File", "filename" ; + +Once you have done that, you can access the Berkeley DB API functions +as B<DB_File> methods directly like this: + + $db->put($key, $value, R_NOOVERWRITE) ; + +B<Important:> If you have saved a copy of the object returned from +C<tie>, the underlying database file will I<not> be closed until both +the tied variable is untied and all copies of the saved object are +destroyed. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; + +See L<The untie() Gotcha> for more details. + +All the functions defined in L<dbopen> are available except for +close() and dbopen() itself. The B<DB_File> method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: + +=over 5 + +=item * + +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. + +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. + +=item * + +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B<DB_File> method does exactly the same. + +=item * + +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; + +The code above can be rearranged to get around the problem, like this: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; + +=back + +All the constants defined in L<dbopen> for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. + +Below is a list of the methods available. + +=over 5 + +=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> + +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. + +If the key does not exist the method returns 1. + +No flags are currently defined for this method. + +=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> + +Stores the key/value pair in the database. + +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. + +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. + +=item B<$status = $X-E<gt>del($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-E<gt>fd ;> + +Returns the file descriptor for the underlying database. + +See L<Locking: The Trouble with fd> for an explanation for why you should +not use C<fd> to lock your database. + +=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L<dbopen> for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-E<gt>sync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 DBM FILTERS + +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a +DBM database. + +There are four methods associated with DBM Filters. All work identically, +and each is used to install (or uninstall) a single DBM Filter. Each +expects a single parameter, namely a reference to a sub. The only +difference between them is the place that the filter is installed. + +To summarise: + +=over 5 + +=item B<filter_store_key> + +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. + +=item B<filter_store_value> + +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. + + +=item B<filter_fetch_key> + +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. + +=item B<filter_fetch_value> + +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. + +=back + +You can use any combination of the methods, from none, to all four. + +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database +that you need to share with a third-party C application. The C application +assumes that I<all> keys and values are NULL terminated. Unfortunately +when Perl writes to DBM databases it doesn't use NULL termination, so +your Perl application will have to manage NULL termination itself. When +you write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use warnings ; + use strict ; + use DB_File ; + + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "soemthing" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use warnings ; + use strict ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 HINTS AND TIPS + + +=head2 Locking: The Trouble with fd + +Until version 1.72 of this module, the recommended technique for locking +B<DB_File> databases was to flock the filehandle returned from the "fd" +function. Unfortunately this technique has been shown to be fundamentally +flawed (Kudos to David Harris for tracking this down). Use it at your own +peril! + +The locking technique went like this. + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + open(DB_FH, "+<&=$fd") || die "dup $!"; + flock (DB_FH, LOCK_EX) || die "flock: $!"; + ... + $db{"Tom"} = "Jerry" ; + ... + flock(DB_FH, LOCK_UN); + undef $db; + untie %db; + close(DB_FH); + +In simple terms, this is what happens: + +=over 5 + +=item 1. + +Use "tie" to open the database. + +=item 2. + +Lock the database with fd & flock. + +=item 3. + +Read & Write to the database. + +=item 4. + +Unlock and close the database. + +=back + +Here is the crux of the problem. A side-effect of opening the B<DB_File> +database in step 2 is that an initial block from the database will get +read from disk and cached in memory. + +To see why this is a problem, consider what can happen when two processes, +say "A" and "B", both want to update the same B<DB_File> database +using the locking steps outlined above. Assume process "A" has already +opened the database and has a write lock, but it hasn't actually updated +the database yet (it has finished step 2, but not started step 3 yet). Now +process "B" tries to open the same database - step 1 will succeed, +but it will block on step 2 until process "A" releases the lock. The +important thing to notice here is that at this point in time both +processes will have cached identical initial blocks from the database. + +Now process "A" updates the database and happens to change some of the +data held in the initial buffer. Process "A" terminates, flushing +all cached data to disk and releasing the database lock. At this point +the database on disk will correctly reflect the changes made by process +"A". + +With the lock released, process "B" can now continue. It also updates the +database and unfortunately it too modifies the data that was in its +initial buffer. Once that data gets flushed to disk it will overwrite +some/all of the changes process "A" made to the database. + +The result of this scenario is at best a database that doesn't contain +what you expect. At worst the database will corrupt. + +The above won't happen every time competing process update the same +B<DB_File> database, but it does illustrate why the technique should +not be used. + +=head2 Safe ways to lock a database + +Starting with version 2.x, Berkeley DB has internal support for locking. +The companion module to this one, B<BerkeleyDB>, provides an interface +to this locking functionality. If you are serious about locking +Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. + +If using B<BerkeleyDB> isn't an option, there are a number of modules +available on CPAN that can be used to implement locking. Each one +implements locking differently and has different goals in mind. It is +therefore worth knowing the difference, so that you can pick the right +one for your application. Here are the three locking wrappers: + +=over 5 + +=item B<Tie::DB_Lock> + +A B<DB_File> wrapper which creates copies of the database file for +read access, so that you have a kind of a multiversioning concurrent read +system. However, updates are still serial. Use for databases where reads +may be lengthy and consistency problems may occur. + +=item B<Tie::DB_LockFile> + +A B<DB_File> wrapper that has the ability to lock and unlock the database +while it is being used. Avoids the tie-before-flock problem by simply +re-tie-ing the database when you get or drop a lock. Because of the +flexibility in dropping and re-acquiring the lock in the middle of a +session, this can be massaged into a system that will work with long +updates and/or reads if the application follows the hints in the POD +documentation. + +=item B<DB_File::Lock> + +An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile +before tie-ing the database and drops the lock after the untie. Allows +one to use the same lockfile for multiple databases to avoid deadlock +problems, if desired. Use for databases where updates are reads are +quick and simple flock locking semantics are enough. + +=back + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. See L<DBM FILTERS> for a generic way to work around this problem. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I<ggh> script (available from your nearest CPAN archive in +F<authors/id/TOMC/scripts/nshist.gz>). + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=head2 The untie() Gotcha + +If you make use of the Berkeley DB API, it is I<very> strongly +recommended that you read L<perltie/The untie Gotcha>. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B<DB_File> +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %x ; + + tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + or die "Cannot tie second time: $!" ; + + untie %x ; + +When run, the script will produce this error message: + + Cannot tie second time: Invalid argument at bad.file line 14. + +Although the error message above refers to the second tie() statement +in the script, the source of the problem is really with the untie() +statement that precedes it. + +Having read L<perltie> you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B<DB_File> destructor, DESTROY, will not be called until I<all> +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F<tst.fil> will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is already open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +which pinpoints the real problem. Finally the script can now be +modified to fix the original problem by destroying the API object +before the untie: + + ... + $x{123} = 456 ; + + undef $X ; + untie %x ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B<DB_File> cannot do this directly, there is a module which +can layer transparently over B<DB_File> to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F<modules/by-module/MLDBM>. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C<tie> call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=head2 What does "Bareword 'DB_File' not allowed" mean? + +You will encounter this particular error message when you have the +C<strict 'subs'> pragma (or the full strict pragma) in your script. +Consider this script: + + use warnings ; + use strict ; + use DB_File ; + my %x ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + Bareword "DB_File" not allowed while "strict subs" in use + +To get around the error, place the word C<DB_File> in either single or +double quotes, like this: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C<use strict> in all your scripts. + +=head1 REFERENCES + +Articles that are either about B<DB_File> or make use of it. + +=over 5 + +=item 1. + +I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), +Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 + +=back + +=head1 HISTORY + +Moved to the Changes file. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. This problem has been fixed since +version 1.85 of Berkeley DB. + +I am sure there are bugs in the code. If you do find any, or can +suggest any enhancements, I would welcome your comments. + +=head1 AVAILABILITY + +B<DB_File> comes with the standard Perl source distribution. Look in +the directory F<ext/DB_File>. Given the amount of time between releases +of Perl the version that ships with Perl is quite likely to be out of +date, so the most recent version can always be found on CPAN (see +L<perlmod/CPAN> for details), in the directory +F<modules/by-module/DB_File>. + +This version of B<DB_File> will work with either version 1.x, 2.x or +3.x of Berkeley DB, but is limited to the functionality provided by +version 1. + +The official web site for Berkeley DB is F<http://www.sleepycat.com>. +All versions of Berkeley DB are available there. + +Alternatively, Berkeley DB version 1 is available at your nearest CPAN +archive in F<src/misc/db.1.85.tar.gz>. + +If you are running IRIX, then get Berkeley DB version 1 from +F<http://reality.sgi.com/ariel>. It has the patches necessary to +compile properly on IRIX 5.3. + +=head1 COPYRIGHT + +Copyright (c) 1995-2002 Paul Marquess. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +Although B<DB_File> is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are are few words taken from the Berkeley DB FAQ (at +F<http://www.sleepycat.com>) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of + Berkeley DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. + + +=head1 SEE ALSO + +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, +L<dbmfilter> + +=head1 AUTHOR + +The DB_File interface was written by Paul Marquess +E<lt>Paul.Marquess@btinternet.comE<gt>. +Questions about the DB system itself may be addressed to +E<lt>db@sleepycat.com<gt>. + +=cut diff --git a/bdb/perl/DB_File/DB_File.xs b/bdb/perl/DB_File/DB_File.xs new file mode 100644 index 00000000000..fba8dede791 --- /dev/null +++ b/bdb/perl/DB_File/DB_File.xs @@ -0,0 +1,1951 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 1st September 2002 + version 1.805 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-2002 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - Fixed a problem with the use of sv_setpvn. When the + size is specified as 0, it does a strlen on the data. + This was ok for DB 1.x, but isn't for DB 2.x. + 1.59 - No change to DB_File.xs + 1.60 - Some code tidy up + 1.61 - added flagSet macro for DB 2.5.x + fixed typo in O_RDONLY test. + 1.62 - No change to DB_File.xs + 1.63 - Fix to alllow DB 2.6.x to build. + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis <kettenis@wins.uva.nl> + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + Rewrote push + 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added suppport to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. + 1.76 - No change to DB_File.xs + 1.77 - Tidied up a few types used in calling newSVpvn. + 1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included. + 1.79 - NEXTKEY ignores the input key. + Added lots of casts + 1.800 - Moved backward compatability code into ppport.h. + Use the new constants code. + 1.801 - No change to DB_File.xs + 1.802 - No change to DB_File.xs + 1.803 - FETCH, STORE & DELETE don't map the flags parameter + into the equivalent Berkeley DB function anymore. + 1.804 - no change. + 1.805 - recursion detection added to the callbacks + Support for 4.1.X added. + Filter code can now cope with read-only $_ + +*/ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef _NOT_CORE +# include "ppport.h" +#endif + +/* Mention DB_VERSION_MAJOR_CFG, DB_VERSION_MINOR_CFG, and + DB_VERSION_PATCH_CFG here so that Configure pulls them all in. */ + +/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be + * shortly #included by the <db.h>) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +/* #if DB_VERSION_MAJOR_CFG < 2 */ +#ifndef DB_VERSION_MAJOR +# undef __attribute__ +#endif + +#ifdef COMPAT185 +# include <db_185.h> +#else +# include <db.h> +#endif + +/* Wall starts with 5.7.x */ + +#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 7) + +/* Since we dropped the gccish definition of __attribute__ we will want + * to redefine dNOOP, however (so that dTHX continues to work). Yes, + * all this means that we can't do attribute checking on the DB_File, + * boo, hiss. */ +# ifndef DB_VERSION_MAJOR + +# undef dNOOP +# define dNOOP extern int Perl___notused + + /* Ditto for dXSARGS. */ +# undef dXSARGS +# define dXSARGS \ + dSP; dMARK; \ + I32 ax = mark - PL_stack_base + 1; \ + I32 items = sp - mark + +# endif + +/* avoid -Wall; DB_File xsubs never make use of `ix' setup for ALIASes */ +# undef dXSI32 +# define dXSI32 dNOOP + +#endif /* Perl >= 5.7 */ + +#include <fcntl.h> + +/* #define TRACE */ + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif + + +#define DBT_clear(x) Zero(&x, 1, DBT) ; + +#ifdef DB_VERSION_MAJOR + +#if DB_VERSION_MAJOR == 2 +# define BERKELEY_DB_1_OR_2 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + +#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_4_1 +#endif + +/* map version 2 features & constants onto their version 1 equivalent */ + +#ifdef DB_Prefix_t +# undef DB_Prefix_t +#endif +#define DB_Prefix_t size_t + +#ifdef DB_Hash_t +# undef DB_Hash_t +#endif +#define DB_Hash_t u_int32_t + +/* DBTYPE stays the same */ +/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ +#if DB_VERSION_MAJOR == 2 + typedef DB_INFO INFO ; +#else /* DB_VERSION_MAJOR > 2 */ +# define DB_FIXEDLEN (0x8000) +#endif /* DB_VERSION_MAJOR == 2 */ + +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; + + +#define R_CURSOR DB_SET_RANGE +#define R_FIRST DB_FIRST +#define R_IAFTER DB_AFTER +#define R_IBEFORE DB_BEFORE +#define R_LAST DB_LAST +#define R_NEXT DB_NEXT +#define R_NOOVERWRITE DB_NOOVERWRITE +#define R_PREV DB_PREV + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define R_SETCURSOR 0x800000 +#else +# define R_SETCURSOR (-100) +#endif + +#define R_RECNOSYNC 0 +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder +#define db_BT_maxkeypage +#define db_BT_minkeypage + + +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder + +#define TXN NULL, + +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) + + +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define flagSet(flags, bitmask) ((flags) & (bitmask)) +#else +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +#endif + +#else /* db version 1.x */ + +#define BERKELEY_DB_1 +#define BERKELEY_DB_1_OR_2 + +typedef union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } INFO ; + + +#ifdef mDB_Prefix_t +# ifdef DB_Prefix_t +# undef DB_Prefix_t +# endif +# define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +# ifdef DB_Hash_t +# undef DB_Hash_t +# endif +# define DB_Hash_t mDB_Hash_t +#endif + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder +#define db_BT_maxkeypage btree.maxkeypage +#define db_BT_minkeypage btree.minkeypage + +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder + +#define TXN + +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) +#define flagSet(flags, bitmask) ((flags) & (bitmask)) + +#endif /* db version 1 */ + + + +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0) + +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) +#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + +#ifdef DB_VERSION_MAJOR +#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\ + (db->dbp->close)(db->dbp, 0) )) +#define db_close(db) ((db->dbp)->close)(db->dbp, 0) +#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ + ? ((db->cursor)->c_del)(db->cursor, 0) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + +#else /* ! DB_VERSION_MAJOR */ + +#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp)) +#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) +#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) + +#endif /* ! DB_VERSION_MAJOR */ + + +#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) + +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + bool in_compare ; + SV * prefix ; + bool in_prefix ; + SV * hash ; + bool in_hash ; + bool aborted ; + int in_memory ; +#ifdef BERKELEY_DB_1_OR_2 + INFO info ; +#endif +#ifdef DB_VERSION_MAJOR + DBC * cursor ; +#endif + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + + } DB_File_type; + +typedef DB_File_type * DB_File ; +typedef DBT DBTKEY ; + +#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + TAINT; \ + SvTAINTED_on(arg); \ + DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + TAINT; \ + SvTAINTED_on(arg); \ + DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ + } + +#define my_SvUV32(sv) ((u_int32_t)SvUV(sv)) + +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + +/* Internal Global Data */ + +#define MY_CXT_KEY "DB_File::_guts" XS_VERSION + +typedef struct { + recno_t x_Value; + recno_t x_zero; + DB_File x_CurrentDB; + DBTKEY x_empty; +} my_cxt_t; + +START_MY_CXT + +#define Value (MY_CXT.x_Value) +#define zero (MY_CXT.x_zero) +#define CurrentDB (MY_CXT.x_CurrentDB) +#define empty (MY_CXT.x_empty) + +#define ERR_BUFF "DB_File::Error" + +#ifdef DB_VERSION_MAJOR + +static int +#ifdef CAN_PROTOTYPE +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) +#else +db_put(db, key, value, flags) +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; +#endif +{ + int status ; + + if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { + DBC * temp_cursor ; + DBT l_key, l_value; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) +#else + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) +#endif + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; + + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } + + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); + + return (status) ; + } + + + if (flagSet(flags, R_CURSOR)) { + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + } + + if (flagSet(flags, R_SETCURSOR)) { + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; + return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); + + } + + return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; + +} + +#endif /* DB_VERSION_MAJOR */ + +static void +tidyUp(DB_File db) +{ + /* db_DESTROY(db); */ + db->aborted = TRUE ; +} + + +static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_compare(const DBT *key1, const DBT *key2) +#else +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif + +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT ; + void * data1, * data2 ; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + + if (CurrentDB->in_compare) { + tidyUp(CurrentDB); + croak ("DB_File btree_compare: recursion detected\n") ; + } + + data1 = (char *) key1->data ; + data2 = (char *) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + CurrentDB->in_compare = TRUE; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_compare = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; + +} + +static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_prefix(const DBT *key1, const DBT *key2) +#else +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT ; + char * data1, * data2 ; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_prefix){ + tidyUp(CurrentDB); + croak ("DB_File btree_prefix: recursion detected\n") ; + } + + data1 = (char *) key1->data ; + data2 = (char *) key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + CurrentDB->in_prefix = TRUE; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_prefix = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + +static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) +#else +hash_cb(data, size) +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + dMY_CXT; + int retval ; + int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_hash){ + tidyUp(CurrentDB); + croak ("DB_File hash callback: recursion detected\n") ; + } + +#ifndef newSVpvn + if (size == 0) + data = "" ; +#endif + + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); + PUTBACK ; + + keep_CurrentDB->in_hash = TRUE; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + CurrentDB = keep_CurrentDB; + CurrentDB->in_hash = FALSE; + + SPAGAIN ; + + if (count != 1){ + tidyUp(CurrentDB); + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + } + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + +static void +#ifdef CAN_PROTOTYPE +db_errcall_cb(const char * db_errpfx, char * buffer) +#else +db_errcall_cb(db_errpfx, buffer) +const char * db_errpfx; +char * buffer; +#endif +{ + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + if (sv) { + if (db_errpfx) + sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ; + else + sv_setpv(sv, buffer) ; + } +} + +#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) + +static void +#ifdef CAN_PROTOTYPE +PrintHash(INFO *hash) +#else +PrintHash(hash) +INFO * hash ; +#endif +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->db_HA_bsize) ; + printf (" ffactor = %d\n", hash->db_HA_ffactor) ; + printf (" nelem = %d\n", hash->db_HA_nelem) ; + printf (" cachesize = %d\n", hash->db_HA_cachesize) ; + printf (" lorder = %d\n", hash->db_HA_lorder) ; + +} + +static void +#ifdef CAN_PROTOTYPE +PrintRecno(INFO *recno) +#else +PrintRecno(recno) +INFO * recno ; +#endif +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno->db_RE_flags) ; + printf (" cachesize = %d\n", recno->db_RE_cachesize) ; + printf (" psize = %d\n", recno->db_RE_psize) ; + printf (" lorder = %d\n", recno->db_RE_lorder) ; + printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; + printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; + printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; +} + +static void +#ifdef CAN_PROTOTYPE +PrintBtree(INFO *btree) +#else +PrintBtree(btree) +INFO * btree ; +#endif +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->db_BT_flags) ; + printf (" cachesize = %d\n", btree->db_BT_cachesize) ; + printf (" psize = %d\n", btree->db_BT_psize) ; +#ifndef DB_VERSION_MAJOR + printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; + printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; +#endif + printf (" lorder = %d\n", btree->db_BT_lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +#ifdef CAN_PROTOTYPE +GetArrayLength(pTHX_ DB_File db) +#else +GetArrayLength(db) +DB_File db ; +#endif +{ + DBT key ; + DBT value ; + int RETVAL ; + + DBT_clear(key) ; + DBT_clear(value) ; + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + + return ((I32)RETVAL) ; +} + +static recno_t +#ifdef CAN_PROTOTYPE +GetRecnoKey(pTHX_ DB_File db, I32 value) +#else +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +#endif +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(aTHX_ db) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) { + tidyUp(db); + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + } + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; +} + + +static DB_File +#ifdef CAN_PROTOTYPE +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) +#else +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; +char * name ; +int flags ; +int mode ; +SV * sv ; +#endif +{ + +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + STRLEN n_a; + dMY_CXT; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info->db_HA_hash = hash_cb ; + RETVAL->hash = newSVsv(*svp) ; + } + else + info->db_HA_hash = NULL ; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_compare = btree_compare ; + RETVAL->compare = newSVsv(*svp) ; + } + else + info->db_BT_compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_prefix = btree_prefix ; + RETVAL->prefix = newSVsv(*svp) ; + } + else + info->db_BT_prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_BT_flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_BT_cachesize = svp ? SvIV(*svp) : 0; + +#ifndef DB_VERSION_MAJOR + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info->btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; +#endif + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_BT_psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_BT_lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + openinfo = (void *)info ; + + info->db_RE_flags = 0 ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "reclen", 6, FALSE); + info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); + +#ifdef DB_VERSION_MAJOR + info->re_source = name ; + name = NULL ; +#endif + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; +#ifdef DB_VERSION_MAJOR + name = (char*) n_a ? ptr : NULL ; +#else + info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; +#endif + } + else +#ifdef DB_VERSION_MAJOR + name = NULL ; +#else + info->db_RE_bfname = NULL ; +#endif + + svp = hv_fetch(action, "bval", 4, FALSE); +#ifdef DB_VERSION_MAJOR + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } + + } +#else + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; + + } + else + { + if (info->db_RE_flags & R_FIXEDLEN) + info->db_RE_bval = (u_char) ' ' ; + else + info->db_RE_bval = (u_char) '\n' ; + DB_flags(info->flags, DB_DELIMITER) ; + } +#endif + +#ifdef DB_RENUMBER + info->flags |= DB_RENUMBER ; +#endif + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + +#ifdef DB_VERSION_MAJOR + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 2.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; + if (status == 0) +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; +#else + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; +#endif + + if (status) + RETVAL->dbp = NULL ; + + } +#else + +#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif /* DB_LIBRARY_COMPATIBILITY_API */ + +#endif + + return (RETVAL) ; + +#else /* Berkeley DB Version > 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; + dMY_CXT; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + status = db_create(&RETVAL->dbp, NULL,0) ; + /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + if (status) { + RETVAL->dbp = NULL ; + return (RETVAL) ; + } + dbp = RETVAL->dbp ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "ffactor", 7, FALSE); + if (svp) + (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "nelem", 5, FALSE); + if (svp) + (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_compare(dbp, btree_compare) ; + RETVAL->compare = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_prefix(dbp, btree_prefix) ; + RETVAL->prefix = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) + (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + int fixed = FALSE ; + + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + } + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = (int)SvIV(*svp) ; + + if (fixed) { + status = dbp->set_re_pad(dbp, value) ; + } + else { + status = dbp->set_re_delim(dbp, value) ; + } + + } + + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = my_SvUV32(*svp) ; + status = dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + status = dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + status = dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, (u_int32_t)flags) ; + } + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + { + u_int32_t Flags = 0 ; + int status ; + + /* Map 1.x flags to 3.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + +#ifdef AT_LEAST_DB_4_1 + status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, + Flags, mode) ; +#else + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; +#endif + /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + + if (status == 0) { + RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; + + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + } + + if (status) + RETVAL->dbp = NULL ; + + } + + return (RETVAL) ; + +#endif /* Berkeley DB Version > 2 */ + +} /* ParseOpenInfo */ + + +#include "constants.h" + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +INCLUDE: constants.xs + +BOOT: + { + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; + MY_CXT_INIT; + __getBerkeleyDBInfo() ; + + DBT_clear(empty) ; + empty.data = &zero ; + empty.size = sizeof(recno_t) ; + } + + + +DB_File +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + STRLEN n_a; + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), n_a) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; + } + OUTPUT: + RETVAL + +int +db_DESTROY(db) + DB_File db + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + Trace(("DESTROY %p\n", db)); + CLEANUP: + Trace(("DESTROY %p done\n", db)); + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; + safefree(db) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + PREINIT: + dMY_CXT; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + +void +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = db_get(db, key, value, flags) ; + ST(0) = sv_newmortal(); + OutputValue(ST(0), value) + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + + +void +db_FIRSTKEY(db) + DB_File db + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +void +db_NEXTKEY(db, key) + DB_File db + DBTKEY key = NO_INIT + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + ALIAS: UNSHIFT = 1 + PREINIT: + dMY_CXT; + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + STRLEN n_a; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; +#else + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; +#ifdef DB_VERSION_MAJOR + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; +#else + RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; +#endif + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +void +pop(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: POP = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } + +void +shift(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: SHIFT = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBT value ; + DBTKEY key ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } + + +I32 +push(db, ...) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + STRLEN n_a; + int keyval ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR + if (RETVAL >= 0) +#endif + { + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; + if (RETVAL != 0) + break; + } + } + } + OUTPUT: + RETVAL + +I32 +length(db) + DB_File db + PREINIT: + dMY_CXT; + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(aTHX_ db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_get(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + PREINIT: + dMY_CXT ; + CODE: + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + RETVAL = -1 ; + { + int status = 0 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; + } +#else + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; +#endif + OUTPUT: + RETVAL + +int +db_sync(db, flags=0) + DB_File db + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + OUTPUT: + RETVAL + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_seq(db, key, value, flags); +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key + value + +SV * +filter_fetch_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_key, code) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_key, code) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_value, code) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_value, code) ; + diff --git a/bdb/perl/DB_File/DB_File_BS b/bdb/perl/DB_File/DB_File_BS new file mode 100644 index 00000000000..9282c498811 --- /dev/null +++ b/bdb/perl/DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/bdb/perl/DB_File/MANIFEST b/bdb/perl/DB_File/MANIFEST new file mode 100644 index 00000000000..b3e1a7bd85b --- /dev/null +++ b/bdb/perl/DB_File/MANIFEST @@ -0,0 +1,30 @@ +Changes +DB_File.pm +DB_File.xs +DB_File_BS +MANIFEST +Makefile.PL +README +config.in +dbinfo +fallback.h +fallback.xs +hints/dynixptx.pl +hints/sco.pl +patches/5.004 +patches/5.004_01 +patches/5.004_02 +patches/5.004_03 +patches/5.004_04 +patches/5.004_05 +patches/5.005 +patches/5.005_01 +patches/5.005_02 +patches/5.005_03 +patches/5.6.0 +ppport.h +t/db-btree.t +t/db-hash.t +t/db-recno.t +typemap +version.c diff --git a/bdb/perl/DB_File/Makefile.PL b/bdb/perl/DB_File/Makefile.PL new file mode 100644 index 00000000000..4c1565d8d01 --- /dev/null +++ b/bdb/perl/DB_File/Makefile.PL @@ -0,0 +1,330 @@ +#! perl -w + +use strict ; +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +die "DB_File needs Perl 5.004_05 or better. This is $]\n" + if $] <= 5.00404; + +my $VER_INFO ; +my $LIB_DIR ; +my $INC_DIR ; +my $DB_NAME ; +my $LIBS ; +my $COMPAT185 = "" ; + +ParseCONFIG() ; + +my @files = ('DB_File.pm', glob "t/*.t") ; +UpDowngrade(@files); + +if (defined $DB_NAME) + { $LIBS = $DB_NAME } +else { + if ($^O eq 'MSWin32') + { $LIBS = '-llibdb' } + else + { $LIBS = '-ldb' } +} + +# Solaris is special. +#$LIBS .= " -lthread" if $^O eq 'solaris' ; + +# AIX is special. +$LIBS .= " -lpthread" if $^O eq 'aix' ; + +# OS2 is a special case, so check for it now. +my $OS2 = "" ; +$OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L${LIB_DIR} $LIBS"], + #MAN3PODS => {}, # Pods will be built by installman. + INC => "-I$INC_DIR", + VERSION_FROM => 'DB_File.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "-D_NOT_CORE $OS2 $VER_INFO $COMPAT185", + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', + #OPTIMIZE => '-g', + 'depend' => { 'Makefile' => 'config.in', + 'version$(OBJ_EXT)' => 'version.c'}, + 'clean' => { FILES => 'constants.h constants.xs' }, + 'macro' => { INSTALLDIRS => 'perl', my_files => "@files" }, + 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz', + DIST_DEFAULT => 'MyDoubleCheck tardist'}, + ); + + +my @names = qw( + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + ); + +if (eval {require ExtUtils::Constant; 1}) { + # Check the constants above all appear in @EXPORT in DB_File.pm + my %names = map { $_, 1} @names; + open F, "<DB_File.pm" or die "Cannot open DB_File.pm: $!\n"; + while (<F>) + { + last if /^\s*\@EXPORT\s+=\s+qw\(/ ; + } + + while (<F>) + { + last if /^\s*\)/ ; + /(\S+)/ ; + delete $names{$1} if defined $1 ; + } + close F ; + + if ( keys %names ) + { + my $missing = join ("\n\t", sort keys %names) ; + die "The following names are missing from \@EXPORT in DB_File.pm\n" . + "\t$missing\n" ; + } + + + ExtUtils::Constant::WriteConstants( + NAME => 'DB_File', + NAMES => \@names, + C_FILE => 'constants.h', + XS_FILE => 'constants.xs', + + ); +} +else { + use File::Copy; + copy ('fallback.h', 'constants.h') + or die "Can't copy fallback.h to constants.h: $!"; + copy ('fallback.xs', 'constants.xs') + or die "Can't copy fallback.xs to constants.xs: $!"; +} + +exit; + + +sub MY::postamble { <<'EOM' } ; + +MyDoubleCheck: + @echo Checking config.in is setup for a release + @(grep "^LIB.*/usr/local/BerkeleyDB" config.in && \ + grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in && \ + grep "^#DBNAME.*" config.in) >/dev/null || \ + (echo config.in needs fixing ; exit 1) + @echo config.in is ok + @echo + @echo Checking DB_File.xs is ok for a release. + @(perl -ne ' exit 1 if /^\s*#\s*define\s+TRACE/ ; ' DB_File.xs || \ + (echo DB_File.xs needs fixing ; exit 1)) + @echo DB_File.xs is ok + @echo + @echo Checking for $$^W in files: $(my_files) + @perl -ne ' \ + exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \ + (echo found unexpected $$^W ; exit 1) + @echo No $$^W found. + @echo + @echo Checking for 'use vars' in files: $(my_files) + @perl -ne ' \ + exit 0 if /^__(DATA|END)__/; \ + exit 1 if /^\s*use\s+vars/;' $(my_files) || \ + (echo found unexpected "use vars"; exit 1) + @echo No 'use vars' found. + @echo + @echo All files are OK for a release. + @echo + +EOM + + + +sub ParseCONFIG +{ + my ($k, $v) ; + my @badkey = () ; + my %Info = () ; + my @Options = qw( INCLUDE LIB PREFIX HASH DBNAME COMPAT185 ) ; + my %ValidOption = map {$_, 1} @Options ; + my %Parsed = %ValidOption ; + my $CONFIG = 'config.in' ; + + print "Parsing $CONFIG...\n" ; + + # DBNAME & COMPAT185 are optional, so pretend they have + # been parsed. + delete $Parsed{'DBNAME'} ; + delete $Parsed{'COMPAT185'} ; + $Info{COMPAT185} = "No" ; + + + open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; + while (<F>) { + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } + } + close F ; + + print "Unknown keys in $CONFIG ignored [@badkey]\n" + if @badkey ; + + # check parsed values + my @missing = () ; + die "The following keys are missing from $CONFIG file: [@missing]\n" + if @missing = keys %Parsed ; + + $INC_DIR = $ENV{'DB_FILE_INCLUDE'} || $Info{'INCLUDE'} ; + $LIB_DIR = $ENV{'DB_FILE_LIB'} || $Info{'LIB'} ; + $DB_NAME = $Info{'DBNAME'} if defined $Info{'DBNAME'} ; + $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" + if (defined $ENV{'DB_FILE_COMPAT185'} && + $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) || + $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; + my $PREFIX = $Info{'PREFIX'} ; + my $HASH = $Info{'HASH'} ; + + $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ; + + print <<EOM if 0 ; + INCLUDE [$INC_DIR] + LIB [$LIB_DIR] + HASH [$HASH] + PREFIX [$PREFIX] + DBNAME [$DB_NAME] + +EOM + + print "Looks Good.\n" ; + +} + +sub UpDowngrade +{ + my @files = @_ ; + + # our is stable from 5.6.0 onward + # warnings is stable from 5.6.1 onward + + # Note: this code assumes that each statement it modifies is not + # split across multiple lines. + + + my $warn_sub ; + my $our_sub ; + + if ($] < 5.006001) { + # From: use|no warnings "blah" + # To: local ($^W) = 1; # use|no warnings "blah" + # + # and + # + # From: warnings::warnif(x,y); + # To: $^W && carp(y); # warnif -- x + $warn_sub = sub { + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + + s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ; + }; + } + else { + # From: local ($^W) = 1; # use|no warnings "blah" + # To: use|no warnings "blah" + # + # and + # + # From: $^W && carp(y); # warnif -- x + # To: warnings::warnif(x,y); + $warn_sub = sub { + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ; + }; + } + + if ($] < 5.006000) { + $our_sub = sub { + if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { + my $indent = $1; + my $vars = join ' ', split /\s*,\s*/, $2; + $_ = "${indent}use vars qw($vars);\n"; + } + }; + } + else { + $our_sub = sub { + if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { + my $indent = $1; + my $vars = join ', ', split ' ', $2; + $_ = "${indent}our ($vars);\n"; + } + }; + } + + foreach (@files) + { doUpDown($our_sub, $warn_sub, $_) } +} + + +sub doUpDown +{ + my $our_sub = shift; + my $warn_sub = shift; + + local ($^I) = ".bak" ; + local (@ARGV) = shift; + + while (<>) + { + print, last if /^__(END|DATA)__/ ; + + &{ $our_sub }(); + &{ $warn_sub }(); + print ; + } + + return if eof ; + + while (<>) + { print } +} + +# end of file Makefile.PL diff --git a/bdb/perl/DB_File/README b/bdb/perl/DB_File/README new file mode 100644 index 00000000000..b09aa9d8aee --- /dev/null +++ b/bdb/perl/DB_File/README @@ -0,0 +1,458 @@ + DB_File + + Version 1.805 + + 1st Sep 2002 + + Copyright (c) 1995-2002 Paul Marquess. All rights reserved. This + program is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + +IMPORTANT NOTICE +================ + +If are using the locking technique described in older versions of +DB_File, please read the section called "Locking: The Trouble with fd" +in DB_File.pm immediately. The locking method has been found to be +unsafe. You risk corrupting your data if you continue to use it. + +DESCRIPTION +----------- + +DB_File is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1. (DB_File can be built +version 2, 3 or 4 of Berkeley DB, but it will only support the 1.x +features), + +If you want to make use of the new features available in Berkeley DB +2.x, 3.x or 4.x, use the Perl module BerkeleyDB instead. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. DB_File provides an interface to all three +of the database types (hash, btree and recno) currently supported by +Berkeley DB. + +For further details see the documentation included at the end of the +file DB_File.pm. + +PREREQUISITES +------------- + +Before you can build DB_File you must have the following installed on +your system: + + * Perl 5.004_05 or greater. + + * Berkeley DB. + + The official web site for Berkeley DB is http://www.sleepycat.com. + The latest version of Berkeley DB is always available there. It + is recommended that you use the most recent version available at + the Sleepycat site. + + The one exception to this advice is where you want to use DB_File + to access database files created by a third-party application, like + Sendmail or Netscape. In these cases you must build DB_File with a + compatible version of Berkeley DB. + + If you want to use Berkeley DB 2.x, you must have version 2.3.4 + or greater. If you want to use Berkeley DB 3.x or 4.x, any version + will do. For Berkeley DB 1.x, use either version 1.85 or 1.86. + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, building the module should +be relatively straightforward. + +Step 1 : If you are running either Solaris 2.5 or HP-UX 10 and want + to use Berkeley DB version 2, 3 or 4, read either the Solaris Notes + or HP-UX Notes sections below. If you are running Linux please + read the Linux Notes section before proceeding. + +Step 2 : Edit the file config.in to suit you local installation. + Instructions are given in the file. + +Step 3 : Build and test the module using this sequence of commands: + + perl Makefile.PL + make + make test + + + NOTE: + If you have a very old version of Berkeley DB (i.e. pre 1.85), + three of the tests in the recno test harness may fail (tests 51, + 53 and 55). You can safely ignore the errors if you're never + going to use the broken functionality (recno databases with a + modified bval). Otherwise you'll have to upgrade your DB + library. + + +INSTALLATION +------------ + + make install + + +TROUBLESHOOTING +=============== + +Here are some of the common problems people encounter when building +DB_File. + +Missing db.h or libdb.a +----------------------- + +If you get an error like this: + + cc -c -I/usr/local/include -Dbool=char -DHAS_BOOL + -O2 -DVERSION=\"1.64\" -DXS_VERSION=\"1.64\" -fpic + -I/usr/local/lib/perl5/i586-linux/5.00404/CORE -DmDB_Prefix_t=size_t + -DmDB_Hash_t=u_int32_t DB_File.c + DB_File.xs:101: db.h: No such file or directory + +or this: + + LD_RUN_PATH="/lib" cc -o blib/arch/auto/DB_File/DB_File.so -shared + -L/usr/local/lib DB_File.o -L/usr/local/lib -ldb + ld: cannot open -ldb: No such file or directory + +This symptom can imply: + + 1. You don't have Berkeley DB installed on your system at all. + Solution: get & install Berkeley DB. + + 2. You do have Berkeley DB installed, but it isn't in a standard place. + Solution: Edit config.in and set the LIB and INCLUDE variables to point + to the directories where libdb.a and db.h are installed. + + +Undefined symbol db_version +--------------------------- + +DB_File seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /usr/bin/perl5.00404 -I./blib/arch -I./blib/lib + -I/usr/local/lib/perl5/i586-linux/5.00404 -I/usr/local/lib/perl5 -e 'use + Test::Harness qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree..........Can't load './blib/arch/auto/DB_File/DB_File.so' for + module DB_File: ./blib/arch/auto/DB_File/DB_File.so: undefined symbol: + db_version at /usr/local/lib/perl5/i586-linux/5.00404/DynaLoader.pm + line 166. + + at t/db-btree.t line 21 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + dubious Test returned status 2 (wstat 512, 0x200) + +This error usually happens when you have both version 1 and version +2 of Berkeley DB installed on your system and DB_File attempts to +build using the db.h for Berkeley DB version 2 and the version 1 +library. Unfortunately the two versions aren't compatible with each +other. The undefined symbol error is actually caused because Berkeley +DB version 1 doesn't have the symbol db_version. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want DB_File to use. + + +Undefined symbol dbopen +----------------------- + +DB_File seems to have built correctly, but you get an error like this +when you run the test harness: + + ... + t/db-btree..........Can't load 'blib/arch/auto/DB_File/DB_File.so' for + module DB_File: blib/arch/auto/DB_File/DB_File.so: undefined symbol: + dbopen at /usr/local/lib/perl5/5.6.1/i586-linux/DynaLoader.pm line 206. + at t/db-btree.t line 23 + Compilation failed in require at t/db-btree.t line 23. + ... + +This error usually happens when you have both version 1 and a more recent +version of Berkeley DB installed on your system and DB_File attempts +to build using the db.h for Berkeley DB version 1 and the newer version +library. Unfortunately the two versions aren't compatible with each +other. The undefined symbol error is actually caused because versions +of Berkeley DB newer than version 1 doesn't have the symbol dbopen. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want DB_File to use. + + +Incompatible versions of db.h and libdb +--------------------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00560 -Iblib/arch + -Iblib/lib -I/home/paul/perl/install/5.005_60/lib/5.00560/i586-linux + -I/home/paul/perl/install/5.005_60/lib/5.00560 -e 'use Test::Harness + qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree.......... + DB_File needs compatible versions of libdb & db.h + you have db.h version 2.3.7 and libdb version 2.7.5 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + ... + +Another variation on the theme of having two versions of Berkeley DB on +your system. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + If you are running Linux, please read the Linux Notes section + below. + + +Linux Notes +----------- + +Newer versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library +that has version 2.x of Berkeley DB linked into it. This makes it +difficult to build this module with anything other than the version of +Berkeley DB that shipped with your Linux release. If you do try to use +a different version of Berkeley DB you will most likely get the error +described in the "Incompatible versions of db.h and libdb" section of +this file. + +To make matters worse, prior to Perl 5.6.1, the perl binary itself +*always* included the Berkeley DB library. + +If you want to use a newer version of Berkeley DB with this module, the +easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x +(or better). + +There are two approaches you can use to get older versions of Perl to +work with specific versions of Berkeley DB. Both have their advantages +and disadvantages. + +The first approach will only work when you want to build a version of +Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use +Berkeley DB 2.x, you must use the next approach. This approach involves +rebuilding your existing version of Perl after applying an unofficial +patch. The "patches" directory in the this module's source distribution +contains a number of patch files. There is one patch file for every +stable version of Perl since 5.004. Apply the appropriate patch to your +Perl source tree before re-building and installing Perl from scratch. +For example, assuming you are in the top-level source directory for +Perl 5.6.0, the command below will apply the necessary patch. Remember +to replace the path shown below with one that points to this module's +patches directory. + + patch -p1 -N </path/to/DB_File/patches/5.6.0 + +Now rebuild & install perl. You should now have a perl binary that can +be used to build this module. Follow the instructions in "BUILDING THE +MODULE", remembering to set the INCLUDE and LIB variables in config.in. + + +The second approach will work with both Berkeley DB 2.x and 3.x. +Start by building Berkeley DB as a shared library. This is from +the Berkeley DB build instructions: + + Building Shared Libraries for the GNU GCC compiler + + If you're using gcc and there's no better shared library example for + your architecture, the following shared library build procedure will + probably work. + + Add the -fpic option to the CFLAGS value in the Makefile. + + Rebuild all of your .o files. This will create a Berkeley DB library + that contains .o files with PIC code. To build the shared library, + then take the following steps in the library build directory: + + % mkdir tmp + % cd tmp + % ar xv ../libdb.a + % gcc -shared -o libdb.so *.o + % mv libdb.so .. + % cd .. + % rm -rf tmp + + Note, you may have to change the gcc line depending on the + requirements of your system. + + The file libdb.so is your shared library + +Once you have built libdb.so, you will need to store it somewhere safe. + + cp libdb.so /usr/local/BerkeleyDB/lib + +If you now set the LD_PRELOAD environment variable to point to this +shared library, Perl will use it instead of the version of Berkeley DB +that shipped with your Linux distribution. + + export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so + +Finally follow the instructions in "BUILDING THE MODULE" to build, +test and install this module. Don't forget to set the INCLUDE and LIB +variables in config.in. + +Remember, you will need to have the LD_PRELOAD variable set anytime you +want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD +permanently set it will affect ALL commands you execute. This may be a +problem if you run any commands that access a database created by the +version of Berkeley DB that shipped with your Linux distribution. + + +Solaris Notes +------------- + +If you are running Solaris 2.5, and you get this error when you run the +DB_File test harness: + + libc internal error: _rmutex_unlock: rmutex not held. + +you probably need to install a Sun patch. It has been reported that +Sun patch 103187-25 (or later revisions) fixes this problem. + +To find out if you have the patch installed, the command "showrev -p" +will display the patches that are currently installed on your system. + + +HP-UX 10 Notes +-------------- + +Some people running HP-UX 10 have reported getting an error like this +when building DB_File with the native HP-UX compiler. + + ld: (Warning) At least one PA 2.0 object file (DB_File.o) was detected. + The linked output may not run on a PA 1.x system. + ld: Invalid loader fixup for symbol "$000000A5". + +If this is the case for you, Berkeley DB needs to be recompiled with +the +z or +Z option and the resulting library placed in a .sl file. The +following steps should do the trick: + + 1: Configure the Berkeley DB distribution with the +z or +Z C compiler + flag: + + env "CFLAGS=+z" ../dist/configure ... + + 2: Edit the Berkeley DB Makefile and change: + + "libdb= libdb.a" to "libdb= libdb.sl". + + + 3: Build and install the Berkeley DB distribution as usual. + +HP-UX 11 Notes +-------------- + +Some people running the combination of HP-UX 11 and Berkeley DB 2.7.7 have +reported getting this error when the run the test harness for DB_File + + ... + lib/db-btree.........Can't call method "DELETE" on an undefined value at lib/db-btree.t line 216. + FAILED at test 26 + lib/db-hash..........Can't call method "DELETE" on an undefined value at lib/db-hash.t line 183. + FAILED at test 22 + ... + +The fix for this is to rebuild and install Berkeley DB with the bigfile +option disabled. + + +IRIX NOTES +---------- + +If you are running IRIX, and want to use Berkeley DB version 1, you can +get it from http://reality.sgi.com/ariel. It has the patches necessary +to compile properly on IRIX 5.3. + + +FEEDBACK +======== + +How to report a problem with DB_File. + +When reporting any problem, I need the information requested below. + + 1. The *complete* output from running this + + perl -V + + Do not edit the output in any way. + Note, I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too + old. DB_File needs Perl version 5.00405 or better. + + 2. The version of DB_File you have. + If you have successfully installed DB_File, this one-liner will + tell you: + + perl -e 'use DB_File; print qq{DB_File ver $DB_File::VERSION\n}' + + If you haven't installed DB_File then search DB_File.pm for a line + like this: + + $VERSION = "1.20" ; + + 3. The version of Berkeley DB you are using. + If you are using a version older than 1.85, think about upgrading. One + point to note if you are considering upgrading Berkeley DB - the + file formats for 1.85, 1.86, 2.0, 3.0 & 3.1 are all different. + + If you have successfully installed DB_File, this command will display + the version of Berkeley DB it was built with: + + perl -e 'use DB_File; print qq{Berkeley DB ver $DB_File::db_ver\n}' + + 4. A copy the file config.in from the DB_File main source directory. + + 5. A listing of directories where Berkeley DB is installed. + For example, if Berkeley DB is installed in /usr/BerkeleDB/lib and + /usr/BerkeleyDB/include, I need the output from running this + + ls -l /usr/BerkeleyDB/lib + ls -l /usr/BerkeleyDB/include + + 6. If you are having problems building DB_File, send me a complete log + of what happened. Start by unpacking the DB_File module into a fresh + directory and keep a log of all the steps + + [edit config.in, if necessary] + perl Makefile.PL + make + make test TEST_VERBOSE=1 + + 7. Now the difficult one. If you think you have found a bug in DB_File + and you want me to fix it, you will *greatly* enhance the chances + of me being able to track it down by sending me a small + self-contained Perl script that illustrates the problem you are + encountering. Include a summary of what you think the problem is + and a log of what happens when you run the script, in case I can't + reproduce your problem on my system. If possible, don't have the + script dependent on an existing 20Meg database. If the script you + send me can create the database itself then that is preferred. + + I realise that in some cases this is easier said than done, so if + you can only reproduce the problem in your existing script, then + you can post me that if you want. Just don't expect me to find your + problem in a hurry, or at all. :-) + + +CHANGES +------- + +See the Changes file. + +Paul Marquess <Paul.Marquess@btinternet.com> diff --git a/bdb/perl/DB_File/config.in b/bdb/perl/DB_File/config.in new file mode 100644 index 00000000000..292b09a5fb3 --- /dev/null +++ b/bdb/perl/DB_File/config.in @@ -0,0 +1,97 @@ +# Filename: config.in +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 9th Sept 1997 +# version 1.55 + +# 1. Where is the file db.h? +# +# Change the path below to point to the directory where db.h is +# installed on your system. + +INCLUDE = /usr/local/BerkeleyDB/include +#INCLUDE = /usr/local/include +#INCLUDE = /usr/include + +# 2. Where is libdb? +# +# Change the path below to point to the directory where libdb is +# installed on your system. + +LIB = /usr/local/BerkeleyDB/lib +#LIB = /usr/local/lib +#LIB = /usr/lib + +# 3. What version of Berkely DB have you got? +# +# If you have version 2.0 or greater, you can skip this question. +# +# If you have Berkeley DB 1.78 or greater you shouldn't have to +# change the definitions for PREFIX and HASH below. +# +# For older versions of Berkeley DB change both PREFIX and HASH to int. +# Version 1.71, 1.72 and 1.73 are known to need this change. +# +# If you don't know what version you have have a look in the file db.h. +# +# Search for the string "DB_VERSION_MAJOR". If it is present, you +# have Berkeley DB version 2 (or greater). +# +# If that didn't work, find the definition of the BTREEINFO typedef. +# Check the return type from the prefix element. It should look like +# this in an older copy of db.h: +# +# int (*prefix) __P((const DBT *, const DBT *)); +# +# and like this in a more recent copy: +# +# size_t (*prefix) /* prefix function */ +# __P((const DBT *, const DBT *)); +# +# Change the definition of PREFIX, below, to reflect the return type +# of the prefix function in your db.h. +# +# Now find the definition of the HASHINFO typedef. Check the return +# type of the hash element. Older versions look like this: +# +# int (*hash) __P((const void *, size_t)); +# +# newer like this: +# +# u_int32_t /* hash function */ +# (*hash) __P((const void *, size_t)); +# +# Change the definition of HASH, below, to reflect the return type of +# the hash function in your db.h. +# + +PREFIX = size_t +HASH = u_int32_t + +# 4. Is the library called libdb? +# +# If you have copies of both 1.x and 2.x Berkeley DB installed on +# your system it can sometimes be tricky to make sure you are using +# the correct one. Renaming one (or creating a symbolic link) to +# include the version number of the library can help. +# +# For example, if you have both Berkeley DB 2.3.12 and 1.85 on your +# system and you want to use the Berkeley DB version 2 library you +# could rename the version 2 library from libdb.a to libdb-2.3.12.a and +# change the DBNAME line below to look like this: +# +# DBNAME = -ldb-2.3.12 +# +# That will ensure you are linking the correct version of the DB +# library. +# +# Note: If you are building this module with Win32, -llibdb will be +# used by default. +# +# If you have changed the name of the library, uncomment the line +# below (by removing the leading #) and edit the line to use the name +# you have picked. + +#DBNAME = -ldb-2.4.10 + +# end of file config.in diff --git a/bdb/perl/DB_File/dbinfo b/bdb/perl/DB_File/dbinfo new file mode 100644 index 00000000000..af2c45facf5 --- /dev/null +++ b/bdb/perl/DB_File/dbinfo @@ -0,0 +1,112 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess <Paul.Marquess@btinternet.com> +# Version: 1.03 +# Date 17th September 2000 +# +# Copyright (c) 1998-2002 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 -> 2.7.7", + 7 => "3.0.x", + 8 => "3.1.x -> 4.0.x", + 9 => "4.1.x or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 -> 2.7.7", + 6 => "3.0.x", + 7 => "3.1.x -> 4.0.x", + 8 => "4.1.x or greater", + } + }, + 0x042253 => { + Type => "Queue", + Versions => + { + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x -> 4.0.x", + 4 => "4.1.x or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +$magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <<EOM ; +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/bdb/perl/DB_File/fallback.h b/bdb/perl/DB_File/fallback.h new file mode 100644 index 00000000000..0213308a0ee --- /dev/null +++ b/bdb/perl/DB_File/fallback.h @@ -0,0 +1,455 @@ +#define PERL_constant_NOTFOUND 1 +#define PERL_constant_NOTDEF 2 +#define PERL_constant_ISIV 3 +#define PERL_constant_ISNO 4 +#define PERL_constant_ISNV 5 +#define PERL_constant_ISPV 6 +#define PERL_constant_ISPVN 7 +#define PERL_constant_ISSV 8 +#define PERL_constant_ISUNDEF 9 +#define PERL_constant_ISUV 10 +#define PERL_constant_ISYES 11 + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif + +static int +constant_6 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_TXN R_LAST R_NEXT R_PREV */ + /* Offset 2 gives the best switch position. */ + switch (name[2]) { + case 'L': + if (memEQ(name, "R_LAST", 6)) { + /* ^ */ +#ifdef R_LAST + *iv_return = R_LAST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "R_NEXT", 6)) { + /* ^ */ +#ifdef R_NEXT + *iv_return = R_NEXT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "R_PREV", 6)) { + /* ^ */ +#ifdef R_PREV + *iv_return = R_PREV; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "DB_TXN", 6)) { + /* ^ */ +#ifdef DB_TXN + *iv_return = DB_TXN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_7 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_LOCK R_FIRST R_NOKEY */ + /* Offset 3 gives the best switch position. */ + switch (name[3]) { + case 'I': + if (memEQ(name, "R_FIRST", 7)) { + /* ^ */ +#ifdef R_FIRST + *iv_return = R_FIRST; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "DB_LOCK", 7)) { + /* ^ */ +#ifdef DB_LOCK + *iv_return = DB_LOCK; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "R_NOKEY", 7)) { + /* ^ */ +#ifdef R_NOKEY + *iv_return = R_NOKEY; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_8 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + DB_SHMEM R_CURSOR R_IAFTER */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'M': + if (memEQ(name, "DB_SHMEM", 8)) { + /* ^ */ +#ifdef DB_SHMEM + *iv_return = DB_SHMEM; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "R_CURSOR", 8)) { + /* ^ */ +#ifdef R_CURSOR + *iv_return = R_CURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'T': + if (memEQ(name, "R_IAFTER", 8)) { + /* ^ */ +#ifdef R_IAFTER + *iv_return = R_IAFTER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_9 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + HASHMAGIC RET_ERROR R_IBEFORE */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'I': + if (memEQ(name, "HASHMAGIC", 9)) { + /* ^ */ +#ifdef HASHMAGIC + *iv_return = HASHMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "RET_ERROR", 9)) { + /* ^ */ +#ifdef RET_ERROR + *iv_return = RET_ERROR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "R_IBEFORE", 9)) { + /* ^ */ +#ifdef R_IBEFORE + *iv_return = R_IBEFORE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_10 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + BTREEMAGIC R_FIXEDLEN R_SNAPSHOT __R_UNUSED */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'E': + if (memEQ(name, "R_FIXEDLEN", 10)) { + /* ^ */ +#ifdef R_FIXEDLEN + *iv_return = R_FIXEDLEN; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'M': + if (memEQ(name, "BTREEMAGIC", 10)) { + /* ^ */ +#ifdef BTREEMAGIC + *iv_return = BTREEMAGIC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "__R_UNUSED", 10)) { + /* ^ */ +#ifdef __R_UNUSED + *iv_return = __R_UNUSED; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': + if (memEQ(name, "R_SNAPSHOT", 10)) { + /* ^ */ +#ifdef R_SNAPSHOT + *iv_return = R_SNAPSHOT; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant_11 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + HASHVERSION RET_SPECIAL RET_SUCCESS R_RECNOSYNC R_SETCURSOR */ + /* Offset 10 gives the best switch position. */ + switch (name[10]) { + case 'C': + if (memEQ(name, "R_RECNOSYNC", 11)) { + /* ^ */ +#ifdef R_RECNOSYNC + *iv_return = R_RECNOSYNC; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "RET_SPECIAL", 11)) { + /* ^ */ +#ifdef RET_SPECIAL + *iv_return = RET_SPECIAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "HASHVERSION", 11)) { + /* ^ */ +#ifdef HASHVERSION + *iv_return = HASHVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'R': + if (memEQ(name, "R_SETCURSOR", 11)) { + /* ^ */ +#ifdef R_SETCURSOR + *iv_return = R_SETCURSOR; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'S': + if (memEQ(name, "RET_SUCCESS", 11)) { + /* ^ */ +#ifdef RET_SUCCESS + *iv_return = RET_SUCCESS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int +constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { + /* Initially switch on the length of the name. */ + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!bleedperl -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +my $types = {map {($_, 1)} qw(IV)}; +my @names = (qw(BTREEMAGIC BTREEVERSION DB_LOCK DB_SHMEM DB_TXN HASHMAGIC + HASHVERSION MAX_PAGE_NUMBER MAX_PAGE_OFFSET MAX_REC_NUMBER + RET_ERROR RET_SPECIAL RET_SUCCESS R_CURSOR R_DUP R_FIRST + R_FIXEDLEN R_IAFTER R_IBEFORE R_LAST R_NEXT R_NOKEY + R_NOOVERWRITE R_PREV R_RECNOSYNC R_SETCURSOR R_SNAPSHOT + __R_UNUSED)); + +print constant_types(); # macro defs +foreach (C_constant ("DB_File", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "#### XS Section:\n"; +print XS_constant ("DB_File", $types); +__END__ + */ + + switch (len) { + case 5: + if (memEQ(name, "R_DUP", 5)) { +#ifdef R_DUP + *iv_return = R_DUP; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 6: + return constant_6 (aTHX_ name, iv_return); + break; + case 7: + return constant_7 (aTHX_ name, iv_return); + break; + case 8: + return constant_8 (aTHX_ name, iv_return); + break; + case 9: + return constant_9 (aTHX_ name, iv_return); + break; + case 10: + return constant_10 (aTHX_ name, iv_return); + break; + case 11: + return constant_11 (aTHX_ name, iv_return); + break; + case 12: + if (memEQ(name, "BTREEVERSION", 12)) { +#ifdef BTREEVERSION + *iv_return = BTREEVERSION; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 13: + if (memEQ(name, "R_NOOVERWRITE", 13)) { +#ifdef R_NOOVERWRITE + *iv_return = R_NOOVERWRITE; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 14: + if (memEQ(name, "MAX_REC_NUMBER", 14)) { +#ifdef MAX_REC_NUMBER + *iv_return = MAX_REC_NUMBER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 15: + /* Names all of length 15. */ + /* MAX_PAGE_NUMBER MAX_PAGE_OFFSET */ + /* Offset 9 gives the best switch position. */ + switch (name[9]) { + case 'N': + if (memEQ(name, "MAX_PAGE_NUMBER", 15)) { + /* ^ */ +#ifdef MAX_PAGE_NUMBER + *iv_return = MAX_PAGE_NUMBER; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'O': + if (memEQ(name, "MAX_PAGE_OFFSET", 15)) { + /* ^ */ +#ifdef MAX_PAGE_OFFSET + *iv_return = MAX_PAGE_OFFSET; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + break; + } + return PERL_constant_NOTFOUND; +} + diff --git a/bdb/perl/DB_File/fallback.xs b/bdb/perl/DB_File/fallback.xs new file mode 100644 index 00000000000..8650cdf7646 --- /dev/null +++ b/bdb/perl/DB_File/fallback.xs @@ -0,0 +1,88 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + /* const char *pv; Uncomment this if you need to return PVs */ + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid DB_File macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined DB_File macro %s, used", s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + /* Uncomment this if you need to return PVs + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; */ + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing DB_File macro %s, used", + type, s)); + PUSHs(sv); + } diff --git a/bdb/perl/DB_File/hints/dynixptx.pl b/bdb/perl/DB_File/hints/dynixptx.pl new file mode 100644 index 00000000000..bb5ffa56e6b --- /dev/null +++ b/bdb/perl/DB_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug + +$self->{LIBS} = ['-lm -lc']; diff --git a/bdb/perl/DB_File/hints/sco.pl b/bdb/perl/DB_File/hints/sco.pl new file mode 100644 index 00000000000..ff604409496 --- /dev/null +++ b/bdb/perl/DB_File/hints/sco.pl @@ -0,0 +1,2 @@ +# osr5 needs to explicitly link against libc to pull in some static symbols +$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/bdb/perl/DB_File/patches/5.004 b/bdb/perl/DB_File/patches/5.004 new file mode 100644 index 00000000000..143ec95afbc --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004 @@ -0,0 +1,44 @@ +diff perl5.004.orig/Configure perl5.004/Configure +190a191 +> perllibs='' +9904a9906,9913 +> : 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="$*" +> +10372a10382 +> perllibs='$perllibs' +diff perl5.004.orig/Makefile.SH perl5.004/Makefile.SH +122c122 +< libs = $libs $cryptlib +--- +> libs = $perllibs $cryptlib +Common subdirectories: perl5.004.orig/Porting and perl5.004/Porting +Common subdirectories: perl5.004.orig/cygwin32 and perl5.004/cygwin32 +Common subdirectories: perl5.004.orig/eg and perl5.004/eg +Common subdirectories: perl5.004.orig/emacs and perl5.004/emacs +Common subdirectories: perl5.004.orig/ext and perl5.004/ext +Common subdirectories: perl5.004.orig/h2pl and perl5.004/h2pl +Common subdirectories: perl5.004.orig/hints and perl5.004/hints +Common subdirectories: perl5.004.orig/lib and perl5.004/lib +diff perl5.004.orig/myconfig perl5.004/myconfig +38c38 +< libs=$libs +--- +> libs=$perllibs +Common subdirectories: perl5.004.orig/os2 and perl5.004/os2 +diff perl5.004.orig/patchlevel.h perl5.004/patchlevel.h +40a41 +> ,"NODB-1.0 - remove -ldb from core perl binary." +Common subdirectories: perl5.004.orig/plan9 and perl5.004/plan9 +Common subdirectories: perl5.004.orig/pod and perl5.004/pod +Common subdirectories: perl5.004.orig/qnx and perl5.004/qnx +Common subdirectories: perl5.004.orig/t and perl5.004/t +Common subdirectories: perl5.004.orig/utils and perl5.004/utils +Common subdirectories: perl5.004.orig/vms and perl5.004/vms +Common subdirectories: perl5.004.orig/win32 and perl5.004/win32 +Common subdirectories: perl5.004.orig/x2p and perl5.004/x2p diff --git a/bdb/perl/DB_File/patches/5.004_01 b/bdb/perl/DB_File/patches/5.004_01 new file mode 100644 index 00000000000..1b05eb4e02b --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_01 @@ -0,0 +1,217 @@ +diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure +*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997 +--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9907,9912 **** +--- 9908,9921 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10375,10380 **** +--- 10384,10390 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH +*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997 +--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm +*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997 +--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000 +*************** +*** 170,176 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 170,176 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm +*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 +--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm +*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 +--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000 +*************** +*** 2137,2143 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2137,2143 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig +*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h +*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997 +--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_02 b/bdb/perl/DB_File/patches/5.004_02 new file mode 100644 index 00000000000..238f8737941 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_02 @@ -0,0 +1,217 @@ +diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure +*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997 +--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH +*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997 +--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm +*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm +*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm +*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997 +--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig +*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h +*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997 +--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_03 b/bdb/perl/DB_File/patches/5.004_03 new file mode 100644 index 00000000000..06331eac922 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_03 @@ -0,0 +1,223 @@ +diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure +*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997 +--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.004_03: Configure.orig +diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH +*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997 +--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.004_03: Makefile.SH.orig +diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm +*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm +*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej +diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm +*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997 +--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig +*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h +*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997 +--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + +Only in perl5.004_03: patchlevel.h.orig diff --git a/bdb/perl/DB_File/patches/5.004_04 b/bdb/perl/DB_File/patches/5.004_04 new file mode 100644 index 00000000000..a227dc700d9 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_04 @@ -0,0 +1,209 @@ +diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure +*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997 +--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9910,9915 **** +--- 9911,9924 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10378,10383 **** +--- 10387,10393 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH +*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997 +--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000 +*************** +*** 129,135 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 129,135 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm +*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm +*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997 +--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 189,195 **** + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 189,195 ---- + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 539,545 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 539,545 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm +*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997 +--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000 +*************** +*** 2229,2235 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2229,2235 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig +*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997 +--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h +*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997 +--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.004_05 b/bdb/perl/DB_File/patches/5.004_05 new file mode 100644 index 00000000000..51c8bf35009 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.004_05 @@ -0,0 +1,209 @@ +diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure +*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 10164,10169 **** +--- 10165,10178 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10648,10653 **** +--- 10657,10663 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH +*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000 +*************** +*** 151,157 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 151,157 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm +*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm +*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 590,596 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 590,596 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm +*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000 +*************** +*** 2246,2252 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2246,2252 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig +*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000 +--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h +*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000 +--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005 b/bdb/perl/DB_File/patches/5.005 new file mode 100644 index 00000000000..effee3e8275 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005 @@ -0,0 +1,209 @@ +diff -rc perl5.005.orig/Configure perl5.005/Configure +*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005/Configure Sun Nov 12 21:30:40 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH +*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm +*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm +*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm +*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005.orig/myconfig perl5.005/myconfig +*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005/myconfig Sun Nov 12 21:30:41 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h +*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998 +--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_01 b/bdb/perl/DB_File/patches/5.005_01 new file mode 100644 index 00000000000..2a05dd545f6 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_01 @@ -0,0 +1,209 @@ +diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure +*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH +*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm +*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm +*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm +*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig +*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h +*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000 +--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_02 b/bdb/perl/DB_File/patches/5.005_02 new file mode 100644 index 00000000000..5dd57ddc03f --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_02 @@ -0,0 +1,264 @@ +diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure +*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000 +--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11334,11339 **** +--- 11335,11348 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11859,11864 **** +--- 11868,11874 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.005_02: Configure.orig +diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH +*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.005_02: Makefile.SH.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm +*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm +*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000 +--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 333,339 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 333,339 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 623,629 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 623,629 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +*************** +*** 666,672 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 666,672 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 676,682 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 676,682 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm +*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig +*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h +*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000 +--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000 +*************** +*** 40,45 **** +--- 40,46 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/patches/5.005_03 b/bdb/perl/DB_File/patches/5.005_03 new file mode 100644 index 00000000000..115f9f5b909 --- /dev/null +++ b/bdb/perl/DB_File/patches/5.005_03 @@ -0,0 +1,250 @@ +diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure +*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999 +--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000 +*************** +*** 208,213 **** +--- 208,214 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11642,11647 **** +--- 11643,11656 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 12183,12188 **** +--- 12192,12198 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH +*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999 +--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000 +*************** +*** 58,67 **** + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +--- 58,67 ---- + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +*************** +*** 155,161 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 155,161 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm +*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999 +--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm +*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999 +--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 336,342 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 336,342 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 626,632 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 626,632 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 670,676 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 670,676 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 680,686 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 680,686 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm +*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999 +--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000 +*************** +*** 2284,2290 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2284,2290 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { diff --git a/bdb/perl/DB_File/patches/5.6.0 b/bdb/perl/DB_File/patches/5.6.0 new file mode 100644 index 00000000000..1f9b3b620de --- /dev/null +++ b/bdb/perl/DB_File/patches/5.6.0 @@ -0,0 +1,294 @@ +diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure +*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000 +--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000 +*************** +*** 217,222 **** +--- 217,223 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 14971,14976 **** +--- 14972,14985 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 15640,15645 **** +--- 15649,15655 ---- + path_sep='$path_sep' + perl5='$perl5' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH +*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000 +--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000 +*************** +*** 70,76 **** + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +--- 70,76 ---- + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +*************** +*** 176,182 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 176,182 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +*************** +*** 333,339 **** + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $libs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +--- 333,339 ---- + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $perllibs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm +*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000 +--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000 +*************** +*** 193,199 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 193,199 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm +*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000 +--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000 +*************** +*** 17,34 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 17,34 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 198,204 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 198,204 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 338,344 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 338,344 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 624,630 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 624,630 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 668,674 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 668,674 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 678,684 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 678,684 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm +*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000 +--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000 +*************** +*** 2450,2456 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2450,2456 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH +*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000 +--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000 +*************** +*** 48,54 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 48,54 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h +*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000 +--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000 +*************** +*** 70,75 **** +--- 70,76 ---- + #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl/DB_File/ppport.h b/bdb/perl/DB_File/ppport.h new file mode 100644 index 00000000000..0887c2159a9 --- /dev/null +++ b/bdb/perl/DB_File/ppport.h @@ -0,0 +1,329 @@ +/* This file is Based on output from + * Perl/Pollution/Portability Version 2.0000 */ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef PERL_REVISION +# ifndef __PATCHLEVEL_H_INCLUDED__ +# include "patchlevel.h" +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +#ifndef ERRSV +# define ERRSV perl_get_sv("@",FALSE) +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_defgv defgv +# define PL_dirty dirty +# define PL_hints hints +# define PL_na na +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stdingv stdingv +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +/* Replace: 0 */ +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef PTR2IV +# define PTR2IV(d) (IV)(d) +#endif + +#ifndef INT2PTR +# define INT2PTR(any,d) (any)(d) +#endif + +#ifndef dTHR +# ifdef WIN32 +# define dTHR extern int Perl___notused +# else +# define dTHR extern int errno +# endif +#endif + +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + +#ifndef newSVpvn +# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) +#endif + +#ifndef newRV_inc +/* Replace: 1 */ +# define newRV_inc(sv) newRV(sv) +/* Replace: 0 */ +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef newRV_noinc +# ifdef __GNUC__ +# define newRV_noinc(sv) \ + ({ \ + SV *nsv = (SV*)newRV(sv); \ + SvREFCNT_dec(sv); \ + nsv; \ + }) +# else +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +static SV * newRV_noinc (SV * sv) +{ + SV *nsv = (SV*)newRV(sv); + SvREFCNT_dec(sv); + return nsv; +} +# else +# define newRV_noinc(sv) \ + ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) +# endif +# endif +#endif + +/* Provide: newCONSTSUB */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) + +#if defined(NEED_newCONSTSUB) +static +#else +extern void newCONSTSUB _((HV * stash, char * name, SV *sv)); +#endif + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) +void +newCONSTSUB(stash,name,sv) +HV *stash; +char *name; +SV *sv; +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) + /* before 5.003_22 */ + start_subparse(), +#else +# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) + /* 5.003_22 */ + start_subparse(0), +# else + /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +# endif +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif + +#endif /* newCONSTSUB */ + + +#ifndef START_MY_CXT + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if PERL_REVISION == 5 && \ + (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#else /* single interpreter */ + +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifdef HASATTRIBUTE +# define PERL_UNUSED_DECL __attribute__((unused)) +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif + +#endif /* START_MY_CXT */ + + +#ifndef DBM_setFilter + +/* + The DBM_setFilter & DBM_ckFilter macros are only used by + the *DB*_File modules +*/ + +#define DBM_setFilter(db_type,code) \ + { \ + if (db_type) \ + RETVAL = sv_mortalcopy(db_type) ; \ + ST(0) = RETVAL ; \ + if (db_type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db_type) ; \ + db_type = NULL ; \ + } \ + else if (code) { \ + if (db_type) \ + sv_setsv(db_type, code) ; \ + else \ + db_type = newSVsv(code) ; \ + } \ + } + +#define DBM_ckFilter(arg,type,name) \ + if (db->type) { \ + if (db->filtering) { \ + croak("recursion detected in %s", name) ; \ + } \ + ENTER ; \ + SAVETMPS ; \ + SAVEINT(db->filtering) ; \ + db->filtering = TRUE ; \ + SAVESPTR(DEFSV) ; \ + DEFSV = arg ; \ + SvTEMP_off(arg) ; \ + PUSHMARK(SP) ; \ + PUTBACK ; \ + (void) perl_call_sv(db->type, G_DISCARD); \ + SPAGAIN ; \ + PUTBACK ; \ + FREETMPS ; \ + LEAVE ; \ + } + +#endif /* DBM_setFilter */ + +#endif /* _P_P_PORTABILITY_H_ */ diff --git a/bdb/perl/DB_File/t/db-btree.t b/bdb/perl/DB_File/t/db-btree.t new file mode 100644 index 00000000000..a990a5c4ba5 --- /dev/null +++ b/bdb/perl/DB_File/t/db-btree.t @@ -0,0 +1,1489 @@ +#!./perl -w + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } + if ($^O eq 'darwin' + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + warn <<EOM; +# +# This test is known to crash in Mac OS X versions 10.1.4 (or earlier) +# because of the buggy Berkeley DB version included with the OS. +# +EOM + } +} + +use DB_File; +use Fcntl; + +print "1..177\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef ; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + $result = normalise($result) ; + return $result ; +} + +sub docat_del +{ + my $file = shift; + my $result = docat($file); + unlink $file ; + return $result ; +} + +sub normalise +{ + my $data = shift ; + $data =~ s#\r\n#\n#g + if $^O eq 'cygwin' ; + + return $data ; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} + + + +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +my $Dfile = "dbbtree.tmp"; +unlink $Dfile; + +umask(0); + +# Check the interface to BTREEINFO + +my $dbh = new DB_File::BTREEINFO ; +ok(1, ! defined $dbh->{flags}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{lorder}) ; +ok(5, ! defined $dbh->{minkeypage}) ; +ok(6, ! defined $dbh->{maxkeypage}) ; +ok(7, ! defined $dbh->{compare}) ; +ok(8, ! defined $dbh->{prefix}) ; + +$dbh->{flags} = 3000 ; +ok(9, $dbh->{flags} == 3000) ; + +$dbh->{cachesize} = 9000 ; +ok(10, $dbh->{cachesize} == 9000); + +$dbh->{psize} = 400 ; +ok(11, $dbh->{psize} == 400) ; + +$dbh->{lorder} = 65 ; +ok(12, $dbh->{lorder} == 65) ; + +$dbh->{minkeypage} = 123 ; +ok(13, $dbh->{minkeypage} == 123) ; + +$dbh->{maxkeypage} = 1234 ; +ok(14, $dbh->{maxkeypage} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; + +# Now check the interface to BTREE + +my ($X, %h) ; +ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; +die "Could not tie: $!" unless $X; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) + || $noMode{$^O} ); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(19, !$i ) ; + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(20, $h{'abc'} eq 'ABC' ); +ok(21, ! defined $h{'jimmy'} ) ; +ok(22, ! exists $h{'jimmy'} ) ; +ok(23, defined $h{'abc'} ) ; + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + +# tie to the same file again +ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(25, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(26, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(27, $#keys == 31) ; + +#Check that the keys can be retrieved in order +my @b = keys %h ; +my @c = sort lexical @b ; +ok(28, ArrayCompare(\@b, \@c)) ; + +$h{'foo'} = ''; +ok(29, $h{'foo'} eq '' ) ; + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(30, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(31, $ok); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(32, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(33, join(':',200..400) eq join(':',@foo) ); + +# Now check all the non-tie specific stuff + + +# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(34, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(35, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(36, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(37, $status == 0 ); +ok(38, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(39, $status == 0 ); +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(40, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +ok(41, ! defined $h{'q'}) ; +ok(42, ! defined $h{''}) ; + +undef $X ; +untie %h ; + +ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(44, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(45, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(46, $status == 0 ); +ok(47, $value eq 'A' ); + +# seq +# ### + +# use seq to find an approximate match +$key = 'ke' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(48, $status == 0 ); +ok(49, $key eq 'key' ); +ok(50, $value eq 'value' ); + +# seq when the key does not match +$key = 'zzz' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(51, $status == 1 ); + + +# use seq to set the cursor, then delete the record @ the cursor. + +$key = 'x' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(52, $status == 0 ); +ok(53, $key eq 'x' ); +ok(54, $value eq 'X' ); +$status = $X->del(0, R_CURSOR) ; +ok(55, $status == 0 ); +$status = $X->get('x', $value) ; +ok(56, $status == 1 ); + +# ditto, but use put to replace the key/value pair. +$key = 'y' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(57, $status == 0 ); +ok(58, $key eq 'y' ); +ok(59, $value eq 'Y' ); + +$key = "replace key" ; +$value = "replace value" ; +$status = $X->put($key, $value, R_CURSOR) ; +ok(60, $status == 0 ); +ok(61, $key eq 'replace key' ); +ok(62, $value eq 'replace value' ); +$status = $X->get('y', $value) ; +ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1) + # only worked because of a bug in 1.85/6 + +# use seq to walk forwards through a file + +$status = $X->seq($key, $value, R_FIRST) ; +ok(64, $status == 0 ); +my $previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_NEXT)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == 1 ; +} + +ok(65, $status == 1 ); +ok(66, $ok == 1 ); + +# use seq to walk backwards through a file +$status = $X->seq($key, $value, R_LAST) ; +ok(67, $status == 0 ); +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_PREV)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == -1 ; + #print "key = [$key] value = [$value]\n" ; +} + +ok(68, $status == 1 ); +ok(69, $ok == 1 ); + + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(70, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(71, $status != 0 ); + + +undef $X ; +untie %h ; + +unlink $Dfile; + +# Now try an in memory file +my $Y; +ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); + +# fd with an in memory file should return failure +$status = $Y->fd ; +ok(73, $status == -1 ); + + +undef $Y ; +untie %h ; + +# Duplicate keys +my $bt = new DB_File::BTREEINFO ; +$bt->{flags} = R_DUP ; +my ($YY, %hh); +ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; + +$hh{'Wall'} = 'Larry' ; +$hh{'Wall'} = 'Stone' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value +$hh{'Smith'} = 'John' ; +$hh{'mouse'} = 'mickey' ; + +# first work in scalar context +ok(75, scalar $YY->get_dup('Unknown') == 0 ); +ok(76, scalar $YY->get_dup('Smith') == 1 ); +ok(77, scalar $YY->get_dup('Wall') == 4 ); + +# now in list context +my @unknown = $YY->get_dup('Unknown') ; +ok(78, "@unknown" eq "" ); + +my @smith = $YY->get_dup('Smith') ; +ok(79, "@smith" eq "John" ); + +{ +my @wall = $YY->get_dup('Wall') ; +my %wall ; +@wall{@wall} = @wall ; +ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); +} + +# hash +my %unknown = $YY->get_dup('Unknown', 1) ; +ok(81, keys %unknown == 0 ); + +my %smith = $YY->get_dup('Smith', 1) ; +ok(82, keys %smith == 1 && $smith{'John'}) ; + +my %wall = $YY->get_dup('Wall', 1) ; +ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 2); + +undef $YY ; +untie %hh ; +unlink $Dfile; + + +# test multiple callbacks +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; + +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; + +my $dbh2 = new DB_File::BTREEINFO ; +$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; + +my $dbh3 = new DB_File::BTREEINFO ; +$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; + + +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!; +tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!; +tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!; + +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} +@srt_2 = sort { $a cmp $b } @Keys ; +@srt_3 = sort { length $a <=> length $b } @Keys ; + +foreach (@Keys) { + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; +} + +sub ArrayCompare +{ + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; +} + +ok(84, ArrayCompare (\@srt_1, [keys %h]) ); +ok(85, ArrayCompare (\@srt_2, [keys %g]) ); +ok(86, ArrayCompare (\@srt_3, [keys %k]) ); + +untie %h ; +untie %g ; +untie %k ; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +# clear +# ##### + +ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(88, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(89, $i == 0); + +untie %h ; +unlink $Dfile1 ; + +{ + # check that attempting to tie an array to a DB_BTREE will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; + ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(91, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(92, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(93, $@ eq "") ; + main::ok(94, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(97, $@ eq "" ) ; + main::ok(98, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(99, $@ eq "") ; + main::ok(100, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(102, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(103, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(104, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(106, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(107, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(108, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(109, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(111, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(112, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(113, $h{"fred"} eq "joe"); + ok(114, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $db->FIRSTKEY() eq "fred") ; + ok(116, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(117, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(118, $h{"fred"} eq "joe"); + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $db->FIRSTKEY() eq "fred") ; + ok(121, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(123, $result{"store key"} eq "store key - 1: [fred]"); + ok(124, $result{"store value"} eq "store value - 1: [joe]"); + ok(125, ! defined $result{"fetch key"} ); + ok(126, ! defined $result{"fetch value"} ); + ok(127, $_ eq "original") ; + + ok(128, $db->FIRSTKEY() eq "fred") ; + ok(129, $result{"store key"} eq "store key - 1: [fred]"); + ok(130, $result{"store value"} eq "store value - 1: [joe]"); + ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(132, ! defined $result{"fetch value"} ); + ok(133, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(134, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(135, $result{"store value"} eq "store value - 2: [joe john]"); + ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(137, ! defined $result{"fetch value"} ); + ok(138, $_ eq "original") ; + + ok(139, $h{"fred"} eq "joe"); + ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(141, $result{"store value"} eq "store value - 2: [joe john]"); + ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(144, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(147, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, %h); + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $status, $key, $value); + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(150, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my ($filename, $x, %h, $found); + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + use Fcntl ; + + my ($filename, $x, %h, $st, $key, $value); + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(153, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(154, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(155, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # When iterating over a tied hash using "each", the key passed to FETCH + # will be recycled and passed to NEXTKEY. If a Source Filter modifies the + # key in FETCH via a filter_fetch_key method we need to check that the + # modified key doesn't get passed to NEXTKEY. + # Also Test "keys" & "values" while we are at it. + + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my $bad_key = 0 ; + my %h = () ; + my $db ; + ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; + $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; + + $h{'Alpha_ABC'} = 2 ; + $h{'Alpha_DEF'} = 5 ; + + ok(157, $h{'Alpha_ABC'} == 2); + ok(158, $h{'Alpha_DEF'} == 5); + + my ($k, $v) = ("",""); + while (($k, $v) = each %h) {} + ok(159, $bad_key == 0); + + $bad_key = 0 ; + foreach $k (keys %h) {} + ok(160, $bad_key == 0); + + $bad_key = 0 ; + foreach $v (values %h) {} + ok(161, $bad_key == 0); + + undef $db ; + untie %h ; + unlink $Dfile; +} + +{ + # now an error to pass 'compare' a non-code reference + my $dbh = new DB_File::BTREEINFO ; + + eval { $dbh->{compare} = 2 }; + ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/); + + eval { $dbh->{prefix} = 2 }; + ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/); + +} + + +{ + # recursion detection in btree + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::BTREEINFO ; + $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(165, $@ =~ /^DB_File btree_compare: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two callbacks don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::BTREEINFO ; + $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; + + my $dbh2 = new DB_File::BTREEINFO ; + $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; + + + + my (%h); + ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(168, $h1_count > 0); + ok(169, $h1_count == $h2_count); + + ok(170, safeUntie \%hash1); + ok(171, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(173, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (174, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h{"fred"} = "joe" ; + + ok(175, $h{"fred"} eq "joe"); + + ok(176, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (177, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl/DB_File/t/db-hash.t b/bdb/perl/DB_File/t/db-hash.t new file mode 100644 index 00000000000..10623cc82a7 --- /dev/null +++ b/bdb/perl/DB_File/t/db-hash.t @@ -0,0 +1,981 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; + +print "1..143\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + $result = normalise($result) ; + unlink $file ; + return $result; +} + +sub normalise +{ + my $data = shift ; + $data =~ s#\r\n#\n#g + if $^O eq 'cygwin' ; + return $data ; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} + + +my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +unlink $Dfile; + +umask(0); + +# Check the interface to HASHINFO + +my $dbh = new DB_File::HASHINFO ; + +ok(1, ! defined $dbh->{bsize}) ; +ok(2, ! defined $dbh->{ffactor}) ; +ok(3, ! defined $dbh->{nelem}) ; +ok(4, ! defined $dbh->{cachesize}) ; +ok(5, ! defined $dbh->{hash}) ; +ok(6, ! defined $dbh->{lorder}) ; + +$dbh->{bsize} = 3000 ; +ok(7, $dbh->{bsize} == 3000 ); + +$dbh->{ffactor} = 9000 ; +ok(8, $dbh->{ffactor} == 9000 ); + +$dbh->{nelem} = 400 ; +ok(9, $dbh->{nelem} == 400 ); + +$dbh->{cachesize} = 65 ; +ok(10, $dbh->{cachesize} == 65 ); + +my $some_sub = sub {} ; +$dbh->{hash} = $some_sub; +ok(11, $dbh->{hash} eq $some_sub ); + +$dbh->{lorder} = 1234 ; +ok(12, $dbh->{lorder} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + + +# Now check the interface to HASH +my ($X, %h); +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +die "Could not tie: $!" unless $X; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) || + $noMode{$^O} ); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(17, !$i ); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(18, $h{'abc'} eq 'ABC' ); +ok(19, !defined $h{'jimmy'} ); +ok(20, !exists $h{'jimmy'} ); +ok(21, exists $h{'abc'} ); + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again, do not supply a type - should default to HASH +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(23, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(24, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; + +$h{'foo'} = ''; +ok(26, $h{'foo'} eq '' ); + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(28, $ok ); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(29, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(30, join(':',200..400) eq join(':',@foo) ); + + +# Now check all the non-tie specific stuff + +# Check NOOVERWRITE will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(31, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(32, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(33, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(36, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(38, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(39, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); + +# seq +# ### + +# ditto, but use put to replace the key/value pair. + +# use seq to walk backwards through a file - check that this reversed is + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(42, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(43, $status != 0 ); + +undef $X ; +untie %h ; + +unlink $Dfile; + +# clear +# ##### + +ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(45, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(46, $i == 0); + +untie %h ; +unlink $Dfile ; + + +# Now try an in memory file +ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +# fd with an in memory file should return fail +$status = $X->fd ; +ok(48, $status == -1 ); + +undef $X ; +untie %h ; + +{ + # check ability to override the default hashing + my %x ; + my $filename = "xyz" ; + my $hi = new DB_File::HASHINFO ; + $::count = 0 ; + $hi->{hash} = sub { ++$::count ; length $_[0] } ; + ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; + $h{"abc"} = 123 ; + ok(50, $h{"abc"} == 123) ; + untie %x ; + unlink $filename ; + ok(51, $::count >0) ; +} + +{ + # check that attempting to tie an array to a DB_HASH will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; + ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbhash.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + no warnings 'uninitialized'; + my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + my ($k, $v) ; + $k = 'fred'; + ok(67, ! $db->seq($k, $v, R_FIRST) ) ; + ok(68, $k eq "fred") ; + ok(69, $v eq "joe") ; + # fk sk fv sv + ok(70, checkOutput( "fred", "fred", "joe", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(71, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(73, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $k = 'Fred'; $v =''; + ok(74, ! $db->seq($k, $v, R_FIRST) ) ; + ok(75, $k eq "FRED") ; + ok(76, $v eq "[Jxe]") ; + # fk sk fv sv + ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(78, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(79, $h{"fred"} eq "joe"); + ok(80, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + #ok(77, $db->FIRSTKEY() eq "fred") ; + $k = 'fred'; + ok(81, ! $db->seq($k, $v, R_FIRST) ) ; + ok(82, $k eq "fred") ; + ok(83, $v eq "joe") ; + # fk sk fv sv + ok(84, checkOutput( "fred", "fred", "joe", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(85, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h{"fred"} eq "joe"); + ok(87, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $k = 'fred'; + ok(88, ! $db->seq($k, $v, R_FIRST) ) ; + ok(89, $k eq "fred") ; + ok(90, $v eq "joe") ; + ok(91, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(93, $result{"store key"} eq "store key - 1: [fred]"); + ok(94, $result{"store value"} eq "store value - 1: [joe]"); + ok(95, ! defined $result{"fetch key"} ); + ok(96, ! defined $result{"fetch value"} ); + ok(97, $_ eq "original") ; + + ok(98, $db->FIRSTKEY() eq "fred") ; + ok(99, $result{"store key"} eq "store key - 1: [fred]"); + ok(100, $result{"store value"} eq "store value - 1: [joe]"); + ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(102, ! defined $result{"fetch value"} ); + ok(103, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(104, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(105, $result{"store value"} eq "store value - 2: [joe john]"); + ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(107, ! defined $result{"fetch value"} ); + ok(108, $_ eq "original") ; + + ok(109, $h{"fred"} eq "joe"); + ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(111, $result{"store value"} eq "store value - 2: [joe john]"); + ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(114, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(116, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + our (%h, $k, $v); + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(117, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(118, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(119, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # When iterating over a tied hash using "each", the key passed to FETCH + # will be recycled and passed to NEXTKEY. If a Source Filter modifies the + # key in FETCH via a filter_fetch_key method we need to check that the + # modified key doesn't get passed to NEXTKEY. + # Also Test "keys" & "values" while we are at it. + + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my $bad_key = 0 ; + my %h = () ; + my $db ; + ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; + $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; + + $h{'Alpha_ABC'} = 2 ; + $h{'Alpha_DEF'} = 5 ; + + ok(121, $h{'Alpha_ABC'} == 2); + ok(122, $h{'Alpha_DEF'} == 5); + + my ($k, $v) = ("",""); + while (($k, $v) = each %h) {} + ok(123, $bad_key == 0); + + $bad_key = 0 ; + foreach $k (keys %h) {} + ok(124, $bad_key == 0); + + $bad_key = 0 ; + foreach $v (values %h) {} + ok(125, $bad_key == 0); + + undef $db ; + untie %h ; + unlink $Dfile; +} + +{ + # now an error to pass 'hash' a non-code reference + my $dbh = new DB_File::HASHINFO ; + + eval { $dbh->{hash} = 2 }; + ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/); + +} + +{ + # recursion detection in hash + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::HASHINFO ; + $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(128, $@ =~ /^DB_File hash callback: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two hash's don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::HASHINFO ; + $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ; + + my $dbh2 = new DB_File::HASHINFO ; + $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ; + + + + my (%h); + ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(131, $h1_count > 0); + ok(132, $h1_count == $h2_count); + + ok(133, safeUntie \%hash1); + ok(134, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Passing undef for flags and/or mode when calling tie could cause + # Use of uninitialized value in subroutine entry + + + my $warn_count = 0 ; + #local $SIG{__WARN__} = sub { ++ $warn_count }; + my %hash1; + unlink $Dfile; + + tie %hash1, 'DB_File',$Dfile, undef; + ok(135, $warn_count == 0); + $warn_count = 0; + tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef; + ok(136, $warn_count == 0); + tie %hash1, 'DB_File',$Dfile, undef, undef; + ok(137, $warn_count == 0); + $warn_count = 0; + + unlink $Dfile; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(139, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (140, ! $@); + + + # 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(141, $h{"fred"} eq "joe"); + + ok(142, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (143, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl/DB_File/t/db-recno.t b/bdb/perl/DB_File/t/db-recno.t new file mode 100644 index 00000000000..5390b549376 --- /dev/null +++ b/bdb/perl/DB_File/t/db-recno.t @@ -0,0 +1,1428 @@ +#!./perl -w + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use warnings; +use strict; +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; +our ($dbh, $Dfile, $bad_ones, $FA); + +# full tied array support started in Perl 5.004_57 +# Double check to see if it is available. + +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + $FA = 0 ; + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + + return $result ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + normalise($result) ; + return $result; +} + +sub docat_del +{ + my $file = shift; + my $result = docat($file); + unlink $file ; + return $result; +} + +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie @$hashref; + return $no_inner; +} + +sub bad_one +{ + unless ($bad_ones++) { + print STDERR <<EOM ; +# +# Some older versions of Berkeley DB version 1 will fail db-recno +# tests 61, 63 and 65. +EOM + if ($^O eq 'darwin' + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + print STDERR <<EOM ; +# +# For example Mac OS X 10.1.4 (or earlier) has such an old +# version of Berkeley DB. +EOM + } + + print STDERR <<EOM ; +# +# You can safely ignore the errors if you're never going to use the +# broken functionality (recno databases with a modified bval). +# Otherwise you'll have to upgrade your DB library. +# +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. +# +EOM + } +} + +sub normalise +{ + return unless $^O eq 'cygwin' ; + foreach (@_) + { s#\r\n#\n#g } +} + +BEGIN +{ + { + local $SIG{__DIE__} ; + eval { require Data::Dumper ; import Data::Dumper } ; + } + + if ($@) { + *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ; + } +} + +my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms +my $total_tests = 158 ; +$total_tests += $splice_tests if $FA ; +print "1..$total_tests\n"; + +$Dfile = "recno.tmp"; +unlink $Dfile ; + +umask(0); + +# Check the interface to RECNOINFO + +$dbh = new DB_File::RECNOINFO ; +ok(1, ! defined $dbh->{bval}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{flags}) ; +ok(5, ! defined $dbh->{lorder}) ; +ok(6, ! defined $dbh->{reclen}) ; +ok(7, ! defined $dbh->{bfname}) ; + +$dbh->{bval} = 3000 ; +ok(8, $dbh->{bval} == 3000 ); + +$dbh->{cachesize} = 9000 ; +ok(9, $dbh->{cachesize} == 9000 ); + +$dbh->{psize} = 400 ; +ok(10, $dbh->{psize} == 400 ); + +$dbh->{flags} = 65 ; +ok(11, $dbh->{flags} == 65 ); + +$dbh->{lorder} = 123 ; +ok(12, $dbh->{lorder} == 123 ); + +$dbh->{reclen} = 1234 ; +ok(13, $dbh->{reclen} == 1234 ); + +$dbh->{bfname} = 1234 ; +ok(14, $dbh->{bfname} == 1234 ); + + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); + +# Now check the interface to RECNOINFO + +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + +my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; + +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) + || $noMode{$^O} ); + +#my $l = @h ; +my $l = $X->length ; +ok(19, ($FA ? @h == 0 : !$l) ); + +my @data = qw( a b c d ever f g h i j k longername m n o p) ; + +$h[0] = shift @data ; +ok(20, $h[0] eq 'a' ); + +my $ i; +foreach (@data) + { $h[++$i] = $_ } + +unshift (@data, 'a') ; + +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $FA ? @h == @data : $X->length == @data ); + + +# Overwrite an entry & check fetch it +$h[3] = 'replaced' ; +$data[3] = 'replaced' ; +ok(24, $h[3] eq 'replaced' ); + +#PUSH +my @push_data = qw(added to the end) ; +($FA ? push(@h, @push_data) : $X->push(@push_data)) ; +push (@data, @push_data) ; +ok(25, $h[++$i] eq 'added' ); +ok(26, $h[++$i] eq 'to' ); +ok(27, $h[++$i] eq 'the' ); +ok(28, $h[++$i] eq 'end' ); + +# POP +my $popped = pop (@data) ; +my $value = ($FA ? pop @h : $X->pop) ; +ok(29, $value eq $popped) ; + +# SHIFT +$value = ($FA ? shift @h : $X->shift) ; +my $shifted = shift @data ; +ok(30, $value eq $shifted ); + +# UNSHIFT + +# empty list +($FA ? unshift @h,() : $X->unshift) ; +ok(31, ($FA ? @h == @data : $X->length == @data )); + +my @new_data = qw(add this to the start of the array) ; +$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; +unshift (@data, @new_data) ; +ok(32, $FA ? @h == @data : $X->length == @data ); +ok(33, $h[0] eq "add") ; +ok(34, $h[1] eq "this") ; +ok(35, $h[2] eq "to") ; +ok(36, $h[3] eq "the") ; +ok(37, $h[4] eq "start") ; +ok(38, $h[5] eq "of") ; +ok(39, $h[6] eq "the") ; +ok(40, $h[7] eq "array") ; +ok(41, $h[8] eq $data[8]) ; + +# Brief test for SPLICE - more thorough 'soak test' is later. +my @old; +if ($FA) { + @old = splice(@h, 1, 2, qw(bananas just before)); +} +else { + @old = $X->splice(1, 2, qw(bananas just before)); +} +ok(42, $h[0] eq "add") ; +ok(43, $h[1] eq "bananas") ; +ok(44, $h[2] eq "just") ; +ok(45, $h[3] eq "before") ; +ok(46, $h[4] eq "the") ; +ok(47, $h[5] eq "start") ; +ok(48, $h[6] eq "of") ; +ok(49, $h[7] eq "the") ; +ok(50, $h[8] eq "array") ; +ok(51, $h[9] eq $data[8]) ; +$FA ? splice(@h, 1, 3, @old) : $X->splice(1, 3, @old); + +# Now both arrays should be identical + +my $ok = 1 ; +my $j = 0 ; +foreach (@data) +{ + $ok = 0, last if $_ ne $h[$j ++] ; +} +ok(52, $ok ); + +# Neagtive subscripts + +# get the last element of the array +ok(53, $h[-1] eq $data[-1] ); +ok(54, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); + +# get the first element using a negative subscript +eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; +ok(55, $@ eq "" ); +ok(56, $h[0] eq "abcd" ); + +# now try to read before the start of the array +eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; +ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +ok(58, safeUntie \@h); + +unlink $Dfile; + + +{ + # Check bval defaults to \n + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(60, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + ok(61, $x eq "abc\ndef\n\nghi\n") ; +} + +{ + # Change bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{bval} = "-" ; + ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(63, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc-def--ghi-") ; + bad_one() unless $ok ; + ok(64, $ok) ; +} + +{ + # Check R_FIXEDLEN with default bval (space) + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{reclen} = 5 ; + ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(66, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc def ghi ") ; + bad_one() unless $ok ; + ok(67, $ok) ; +} + +{ + # Check R_FIXEDLEN with user-defined bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{bval} = "-" ; + $dbh->{reclen} = 5 ; + ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + ok(69, safeUntie \@h); + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc--def-------ghi--") ; + bad_one() unless $ok ; + ok(70, $ok) ; +} + +{ + # check that attempting to tie an associative array to a DB_RECNO will fail + + my $filename = "xyz" ; + my %x ; + eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; + ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + our (@ISA, @EXPORT); + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE or die "Could not close: $!"; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(72, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + die "Could not tie: $!" unless $X; + + main::ok(73, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(74, $@ eq "") ; + main::ok(75, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(76, $@ eq "") ; + main::ok(77, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(78, $@ eq "" ) ; + main::ok(79, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(80, $@ eq "") ; + main::ok(81, $ret eq "[[11]]") ; + + undef $X; + main::ok(82, main::safeUntie \@h); + unlink "SubDB.pm", "recno.tmp" ; + +} + +{ + + # test $# + my $self ; + unlink $Dfile; + ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[2] = "ghi" ; + $h[3] = "jkl" ; + ok(84, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + ok(85, safeUntie \@h); + my $x = docat($Dfile) ; + ok(86, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to same length + ok(87, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 3 } + else + { $self->STORESIZE(4) } + ok(88, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + ok(89, safeUntie \@h); + $x = docat($Dfile) ; + ok(90, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to bigger + ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 6 } + else + { $self->STORESIZE(7) } + ok(92, $FA ? $#h == 6 : $self->length() == 7) ; + undef $self ; + ok(93, safeUntie \@h); + $x = docat($Dfile) ; + ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + + # $# sets array smaller + ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 2 } + else + { $self->STORESIZE(3) } + ok(96, $FA ? $#h == 2 : $self->length() == 3) ; + undef $self ; + ok(97, safeUntie \@h); + $x = docat($Dfile) ; + ok(98, $x eq "abc\ndef\nghi\n") ; + + unlink $Dfile; + + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(100, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(101, $h[0] eq "joe"); + # fk sk fv sv + ok(102, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(103, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(104, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(105, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(106, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(107, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(108, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(109, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(110, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(111, $h[0] eq "joe"); + ok(112, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(113, $db->FIRSTKEY() == 0) ; + ok(114, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(115, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(116, $h[0] eq "joe"); + ok(117, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(118, $db->FIRSTKEY() == 0) ; + ok(119, checkOutput( "", "", "", "")) ; + + undef $db ; + ok(120, safeUntie \@h); + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(122, $result{"store key"} eq "store key - 1: [0]"); + ok(123, $result{"store value"} eq "store value - 1: [joe]"); + ok(124, ! defined $result{"fetch key"} ); + ok(125, ! defined $result{"fetch value"} ); + ok(126, $_ eq "original") ; + + ok(127, $db->FIRSTKEY() == 0 ) ; + ok(128, $result{"store key"} eq "store key - 1: [0]"); + ok(129, $result{"store value"} eq "store value - 1: [joe]"); + ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(131, ! defined $result{"fetch value"} ); + ok(132, $_ eq "original") ; + + $h[7] = "john" ; + ok(133, $result{"store key"} eq "store key - 2: [0 7]"); + ok(134, $result{"store value"} eq "store value - 2: [joe john]"); + ok(135, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(136, ! defined $result{"fetch value"} ); + ok(137, $_ eq "original") ; + + ok(138, $h[0] eq "joe"); + ok(139, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(140, $result{"store value"} eq "store value - 2: [joe john]"); + ok(141, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(143, $_ eq "original") ; + + undef $db ; + ok(144, safeUntie \@h); + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_store_key (sub { $_ = $h[0] }) ; + + eval '$h[1] = 1234' ; + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + ok(147, safeUntie \@h); + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(148, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use warnings FATAL => qw(all); + use strict ; + our (@h, $H, $file, $i); + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(149, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(150, $a eq "") ; + ok(151, safeUntie \@h); + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(152, $a eq "") ; + ok(153, safeUntie \@h); + unlink $Dfile; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(155, $h[0] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (156, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h[1] = "joe" ; + + ok(157, $h[1] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (158, ! $@); + + undef $db ; + untie @h; + unlink $Dfile; +} + +# Only test splice if this is a newish version of Perl +exit unless $FA ; + +# Test SPLICE + +{ + # check that the splice warnings are under the same lexical control + # as their non-tied counterparts. + + use warnings; + use strict; + + my $a = ''; + my @a = (1); + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @tied ; + + tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + + # uninitialized offset + use warnings; + my $offset ; + $a = ''; + splice(@a, $offset); + ok(159, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, $offset); + ok(160, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, $offset); + ok(161, $a eq ''); + $a = ''; + splice(@tied, $offset); + ok(162, $a eq ''); + + # uninitialized length + use warnings; + my $length ; + $a = ''; + splice(@a, 0, $length); + ok(163, $a =~ /^Use of uninitialized value /); + $a = ''; + splice(@tied, 0, $length); + ok(164, $a =~ /^Use of uninitialized value in splice/); + + no warnings 'uninitialized'; + $a = ''; + splice(@a, 0, $length); + ok(165, $a eq ''); + $a = ''; + splice(@tied, 0, $length); + ok(166, $a eq ''); + + # offset past end of array + use warnings; + $a = ''; + splice(@a, 3); + my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); + $a = ''; + splice(@tied, 3); + ok(167, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); + + no warnings 'misc'; + $a = ''; + splice(@a, 3); + ok(168, $a eq ''); + $a = ''; + splice(@tied, 3); + ok(169, $a eq ''); + + ok(170, safeUntie \@tied); + unlink $Dfile; +} + +# +# These are a few regression tests: bundles of five arguments to pass +# to test_splice(). The first four arguments correspond to those +# given to splice(), and the last says which context to call it in +# (scalar, list or void). +# +# The expected result is not needed because we get that by running +# Perl's built-in splice(). +# +my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', + 'rarely', 'paleness' ], + -4, -2, + [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], + 'void' ], + + [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], + + [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], + 0, -4, + [ 'maids' ], + 'void' ], + + [ [ 'visibility', 'pocketful', 'rectangles' ], + -10, 0, + [ 'garbages' ], + 'void' ], + + [ [ 'sleeplessly' ], + 8, -4, + [ 'Margery', 'clearing', 'repercussion', 'clubs', + 'arise' ], + 'void' ], + + [ [ 'chastises', 'recalculates' ], + 0, 0, + [ 'momentariness', 'mediates', 'accents', 'toils', + 'regaled' ], + 'void' ], + + [ [ 'b', '' ], + 9, 8, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'b', '' ], + undef, undef, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'riheb' ], -8, undef, [], 'void' ], + + [ [ 'uft', 'qnxs', '' ], + 6, -2, + [ 'znp', 'mhnkh', 'bn' ], + 'void' ], + ); + +my $testnum = 171; +my $failed = 0; +require POSIX; my $tmp = POSIX::tmpnam(); +foreach my $test (@tests) { + my $err = test_splice(@$test); + if (defined $err) { + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + ok($testnum++, 0); + } + else { ok($testnum++, 1) } +} + +if ($failed) { + # Not worth running the random ones + print STDERR '# skipping ', $testnum++, "\n"; +} +else { + # A thousand randomly-generated tests + $failed = 0; + srand(0); + foreach (0 .. 1000 - 1) { + my $test = rand_test(); + my $err = test_splice(@$test); + if (defined $err) { + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + print STDERR "# skipping any remaining random tests\n"; + last; + } + } + + ok($testnum++, not $failed); +} + +die "testnum ($testnum) != total_tests ($total_tests) + 1" + if $testnum != $total_tests + 1; + +exit ; + +# Subroutines for SPLICE testing + +# test_splice() +# +# Test the new splice() against Perl's built-in one. The first four +# parameters are those passed to splice(), except that the lists must +# be (explicitly) passed by reference, and are not actually modified. +# (It's just a test!) The last argument specifies the context in +# which to call the functions: 'list', 'scalar', or 'void'. +# +# Returns: +# undef, if the two splices give the same results for the given +# arguments and context; +# +# an error message showing the difference, otherwise. +# +# Reads global variable $tmp. +# +sub test_splice { + die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; + my ($array, $offset, $length, $list, $context) = @_; + my @array = @$array; + my @list = @$list; + + unlink $tmp; + + my @h; + my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO + or die "cannot open $tmp: $!"; + + my $i = 0; + foreach ( @array ) { $h[$i++] = $_ } + + return "basic DB_File sanity check failed" + if list_diff(\@array, \@h); + + # Output from splice(): + # Returned value (munged a bit), error msg, warnings + # + my ($s_r, $s_error, @s_warnings); + + my $gather_warning = sub { push @s_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = []; + } + else { + die "bad context $context"; + } + + foreach ($s_error, @s_warnings) { + chomp; + s/ at \S+ line \d+\.$//; + } + + # Now do the same for DB_File's version of splice + my ($ms_r, $ms_error, @ms_warnings); + $gather_warning = sub { push @ms_warnings, $_[0] }; + if ($context eq 'list') { + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = \@r; + } + elsif ($context eq 'scalar') { + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = [ $r ]; + } + elsif ($context eq 'void') { + eval { + local $SIG{__WARN__} = $gather_warning; + splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = []; + } + else { + die "bad context $context"; + } + + foreach ($ms_error, @ms_warnings) { + chomp; + s/ at \S+ line \d+\.?.*//s; + } + + return "different errors: '$s_error' vs '$ms_error'" + if $s_error ne $ms_error; + return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r)) + if list_diff($s_r, $ms_r); + return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + if ((scalar @s_warnings) != (scalar @ms_warnings)) { + return 'different number of warnings'; + } + + while (@s_warnings) { + my $sw = shift @s_warnings; + my $msw = shift @ms_warnings; + + if (defined $sw and defined $msw) { + $msw =~ s/ \(.+\)$//; + $msw =~ s/ in splice$// if $] < 5.006; + if ($sw ne $msw) { + return "different warning: '$sw' vs '$msw'"; + } + } + elsif (not defined $sw and not defined $msw) { + # Okay. + } + else { + return "one warning defined, another undef"; + } + } + + undef $H; + untie @h; + + open(TEXT, $tmp) or die "cannot open $tmp: $!"; + @h = <TEXT>; normalise @h; chomp @h; + close TEXT or die "cannot close $tmp: $!"; + return('list is different when re-read from disk: ' + . Dumper(\@array) . ' vs ' . Dumper(\@h)) + if list_diff(\@array, \@h); + + return undef; # success +} + + +# list_diff() +# +# Do two lists differ? +# +# Parameters: +# reference to first list +# reference to second list +# +# Returns true iff they differ. Only works for lists of (string or +# undef). +# +# Surely there is a better way to do this? +# +sub list_diff { + die 'usage: list_diff(ref to first list, ref to second list)' + if @_ != 2; + my ($a, $b) = @_; + my @a = @$a; my @b = @$b; + return 1 if (scalar @a) != (scalar @b); + for (my $i = 0; $i < @a; $i++) { + my ($ae, $be) = ($a[$i], $b[$i]); + if (defined $ae and defined $be) { + return 1 if $ae ne $be; + } + elsif (not defined $ae and not defined $be) { + # Two undefined values are 'equal' + } + else { + return 1; + } + } + return 0; +} + + +# rand_test() +# +# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. +# ARRAY or LIST might be empty, and OFFSET or LENGTH might be +# undefined. Return a 'test' - a listref of these five things. +# +sub rand_test { + die 'usage: rand_test()' if @_; + my @contexts = qw<list scalar void>; + my $context = $contexts[int(rand @contexts)]; + return [ rand_list(), + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + rand_list(), + $context ]; +} + + +sub rand_list { + die 'usage: rand_list()' if @_; + my @r; + + while (rand() > 0.1 * (scalar @r + 1)) { + push @r, rand_word(); + } + return \@r; +} + + +sub rand_word { + die 'usage: rand_word()' if @_; + my $r = ''; + my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>; + while (rand() > 0.1 * (length($r) + 1)) { + $r .= $chars[int(rand(scalar @chars))]; + } + return $r; +} + + diff --git a/bdb/perl/DB_File/typemap b/bdb/perl/DB_File/typemap new file mode 100644 index 00000000000..8ad7b1282dc --- /dev/null +++ b/bdb/perl/DB_File/typemap @@ -0,0 +1,46 @@ +# typemap for Perl 5 interface to Berkeley +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 10th December 2000 +# version 1.74 +# +#################################### DB SECTION +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; + if (SvOK($arg)){ + if (db->type != DB_RECNO) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + else { + Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + } + } +T_dbtdatum + DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; + if (SvOK($arg)) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/bdb/perl/DB_File/version.c b/bdb/perl/DB_File/version.c new file mode 100644 index 00000000000..03b17c18e60 --- /dev/null +++ b/bdb/perl/DB_File/version.c @@ -0,0 +1,82 @@ +/* + + version.c -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 2nd Jan 2002 + version 1.802 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-2002 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + 1.72 - No change. + 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + + +*/ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <db.h> + +void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else +__getBerkeleyDBInfo() +#endif +{ +#ifdef dTHX + dTHX; +#endif + SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; + SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; + SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; + +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* Check that the versions of db.h and libdb.a are the same */ + if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR + || Patch != DB_VERSION_PATCH) + croak("\nDB_File 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) ; + + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(version_sv, buffer) ; + sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; + sv_setpv(ver_sv, buffer) ; + } + +#else /* ! DB_VERSION_MAJOR */ + sv_setiv(version_sv, 1) ; + sv_setiv(ver_sv, 1) ; +#endif /* ! DB_VERSION_MAJOR */ + +#ifdef COMPAT185 + sv_setiv(compat_sv, 1) ; +#else /* ! COMPAT185 */ + sv_setiv(compat_sv, 0) ; +#endif /* ! COMPAT185 */ + +} |