Commit 06f2c8c937a54a20b3f42d2d8e117becd730338c - libberkeleydb-perl

+2

-2

BerkeleyDB.pm less more

1	1	package BerkeleyDB;
2	2
3	3
4		# Copyright (c) 1997-2020 Paul Marquess. All rights reserved.
	4	# Copyright (c) 1997-2022 Paul Marquess. All rights reserved.
5	5	# This program is free software; you can redistribute it and/or
6	6	# modify it under the same terms as Perl itself.
7	7	#

16	16	use vars qw($VERSION @ISA @EXPORT $AUTOLOAD
17	17	$use_XSLoader);
18	18
19		$VERSION = '0.64';
	19	$VERSION = '0.65';
20	20
21	21	require Exporter;
22	22

+4

-18

BerkeleyDB.pod less more

2723	2723
2724	2724	=head1 COPYRIGHT
2725	2725
2726		Copyright (c) 1997-2020 Paul Marquess. All rights reserved. This program
	2726	Copyright (c) 1997-2022 Paul Marquess. All rights reserved. This program
2727	2727	is free software; you can redistribute it and/or modify it under the
2728	2728	same terms as Perl itself.
2729	2729
2730	2730	Although B<BerkeleyDB> is covered by the Perl license, the library it
2731	2731	makes use of, namely Berkeley DB, is not. Berkeley DB has its own
2732		copyright and its own license. Please take the time to read it.
2733
2734		Here are few words taken from the Berkeley DB FAQ (at
2735		F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
2736
2737		Do I have to license DB to use it in Perl scripts?
2738
2739		No. The Berkeley DB license requires that software that uses
2740		Berkeley DB be freely redistributable. In the case of Perl, that
2741		software is Perl, and not your scripts. Any Perl scripts that you
2742		write are your property, including scripts that make use of Berkeley
2743		DB. Neither the Perl license nor the Berkeley DB license
2744		place any restriction on what you may do with them.
2745
2746		If you are in any doubt about the license situation, contact either the
2747		Berkeley DB authors or the author of BerkeleyDB.
2748		See L<"AUTHOR"> for details.
	2732	copyright and its own license.
	2733	See L<AGPL\|https://www.oracle.com/downloads/licenses/berkeleydb-oslicense.html> for more details.
	2734	Please take the time to read the Berkeley DB license and decide how it impacts your use of this Perl module.
2749	2735
2750	2736
2751	2737	=head1 AUTHOR

+4

-18

BerkeleyDB.pod.P less more

2490	2490
2491	2491	=head1 COPYRIGHT
2492	2492
2493		Copyright (c) 1997-2020 Paul Marquess. All rights reserved. This program
	2493	Copyright (c) 1997-2022 Paul Marquess. All rights reserved. This program
2494	2494	is free software; you can redistribute it and/or modify it under the
2495	2495	same terms as Perl itself.
2496	2496
2497	2497	Although B<BerkeleyDB> is covered by the Perl license, the library it
2498	2498	makes use of, namely Berkeley DB, is not. Berkeley DB has its own
2499		copyright and its own license. Please take the time to read it.
2500
2501		Here are few words taken from the Berkeley DB FAQ (at
2502		F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
2503
2504		Do I have to license DB to use it in Perl scripts?
2505
2506		No. The Berkeley DB license requires that software that uses
2507		Berkeley DB be freely redistributable. In the case of Perl, that
2508		software is Perl, and not your scripts. Any Perl scripts that you
2509		write are your property, including scripts that make use of Berkeley
2510		DB. Neither the Perl license nor the Berkeley DB license
2511		place any restriction on what you may do with them.
2512
2513		If you are in any doubt about the license situation, contact either the
2514		Berkeley DB authors or the author of BerkeleyDB.
2515		See L<"AUTHOR"> for details.
	2499	copyright and its own license.
	2500	See L<AGPL\|https://www.oracle.com/downloads/licenses/berkeleydb-oslicense.html> for more details.
	2501	Please take the time to read the Berkeley DB license and decide how it impacts your use of this Perl module.
2516	2502
2517	2503
2518	2504	=head1 AUTHOR

+118

-119

BerkeleyDB.xs less more

168	168	# define AT_LEAST_DB_5_3
169	169	#endif
170	170
171		#if DB_VERSION_MAJOR >= 6
	171	#if DB_VERSION_MAJOR >= 6
172	172	# define AT_LEAST_DB_6_0
173	173	#endif
174	174

193	193	# define DB_QUEUE 4
194	194	#endif /* DB_VERSION_MAJOR == 2 */
195	195
196		#if DB_VERSION_MAJOR == 2
	196	#if DB_VERSION_MAJOR == 2
197	197	# define BackRef internal
198	198	#else
199	199	# if DB_VERSION_MAJOR == 3 \|\| (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR == 0)

503	503	# define flagSetBoth() (flagSet(DB_GET_BOTH) \|\| flagSet(DB_GET_BOTH_RANGE))
504	504	#else
505	505	# define flagSetBoth() (flagSet(DB_GET_BOTH))
506		#endif
	506	#endif
507	507
508	508	#ifndef AT_LEAST_DB_4
509	509	typedef int db_timeout_t ;

649	649	}
650	650	#else
651	651	#define InputKey_seq(arg, var)
652		#define OutputKey_seq(arg, name)
	652	#define OutputKey_seq(arg, name)
653	653	#endif
654	654
655	655	#define OutputKey_B(arg, name) \

717	717	#ifdef AT_LEAST_DB_4_3
718	718	#define ckActive_Sequence(a) ckActive(a, "Sequence")
719	719	#else
720		#define ckActive_Sequence(a)
721		#endif
722
723		#define dieIfEnvOpened(e, m) if (e->opened) softCrash("Cannot call method BerkeleyDB::Env::%s after environment has been opened", m);
	720	#define ckActive_Sequence(a)
	721	#endif
	722
	723	#define dieIfEnvOpened(e, m) if (e->opened) softCrash("Cannot call method BerkeleyDB::Env::%s after environment has been opened", m);
724	724
725	725	#define isSTDOUT_ERR(f) ((f) == stdout \|\| (f) == stderr)
726	726

729	729	#define MY_CXT_KEY "BerkeleyDB::_guts" XS_VERSION
730	730
731	731	typedef struct {
732		db_recno_t x_Value;
	732	db_recno_t x_Value;
733	733	db_recno_t x_zero;
734	734	DBTKEY x_empty;
735	735	#ifndef AT_LEAST_DB_3_2

741	741
742	742	#define Value (MY_CXT.x_Value)
743	743	#define zero (MY_CXT.x_zero)
744		#define empty (MY_CXT.x_empty)
	744	#define empty (MY_CXT.x_empty)
745	745
746	746	#ifdef AT_LEAST_DB_3_2
747		# define CurrentDB ((BerkeleyDB)db->BackRef)
	747	# define CurrentDB ((BerkeleyDB)db->BackRef)
748	748	#else
749	749	# define CurrentDB (MY_CXT.x_CurrentDB)
750	750	#endif
751	751
752	752	#ifdef AT_LEAST_DB_3_2
753		# define getCurrentDB ((BerkeleyDB)db->BackRef)
754		# define saveCurrentDB(db)
	753	# define getCurrentDB ((BerkeleyDB)db->BackRef)
	754	# define saveCurrentDB(db)
755	755	#else
756	756	# define getCurrentDB (MY_CXT.x_CurrentDB)
757	757	# define saveCurrentDB(db) (MY_CXT.x_CurrentDB) = db

768	768	void *
769	769	MyRealloc(void * ptr, size_t size)
770	770	{
771		if (ptr == NULL )
772		return safemalloc(size) ;
	771	if (ptr == NULL )
	772	return safemalloc(size) ;
773	773	else
774	774	return saferealloc(ptr, size) ;
775	775	}

854	854	{
855	855	#ifdef dTHX
856	856	dTHX;
857		#endif
	857	#endif
858	858	Trace(("close_everything\n")) ;
859	859	/* Abort All Transactions */
860	860	{

990	990	{
991	991	#ifdef dTHX
992	992	dTHX;
993		#endif
	993	#endif
994	994	if (! PL_dirty && db->active) {
995	995	if (db->parent_env && db->parent_env->open_dbs)
996	996	-- db->parent_env->open_dbs ;

1088	1088	DB_BTREE_STAT * stat ;
1089	1089	#ifdef AT_LEAST_DB_4_3
1090	1090	db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, 0) ;
1091		#else
	1091	#else
1092	1092	#ifdef AT_LEAST_DB_3_3
1093	1093	db->Status = ((db->dbp)->stat)(db->dbp, &stat, 0) ;
1094	1094	#else

1116	1116	DB_QUEUE_STAT * stat ;
1117	1117	#ifdef AT_LEAST_DB_4_3
1118	1118	db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, 0) ;
1119		#else
	1119	#else
1120	1120	#ifdef AT_LEAST_DB_3_3
1121	1121	db->Status = ((db->dbp)->stat)(db->dbp, &stat, 0) ;
1122	1122	#else

1225	1225	{
1226	1226	#ifdef dTHX
1227	1227	dTHX;
1228		#endif
	1228	#endif
1229	1229	dSP ;
1230		dMY_CXT ;
	1230	dMY_CXT ;
1231	1231	char * data1, * data2 ;
1232	1232	int retval ;
1233	1233	int count ;

1285	1285	{
1286	1286	#ifdef dTHX
1287	1287	dTHX;
1288		#endif
	1288	#endif
1289	1289	dSP ;
1290		dMY_CXT ;
	1290	dMY_CXT ;
1291	1291	char * data1, * data2 ;
1292	1292	int retval ;
1293	1293	int count ;

1346	1346	{
1347	1347	#ifdef dTHX
1348	1348	dTHX;
1349		#endif
	1349	#endif
1350	1350	dSP ;
1351		dMY_CXT ;
	1351	dMY_CXT ;
1352	1352	char * data1, * data2 ;
1353	1353	int retval ;
1354	1354	int count ;

1400	1400	{
1401	1401	#ifdef dTHX
1402	1402	dTHX;
1403		#endif
	1403	#endif
1404	1404	dSP ;
1405		dMY_CXT ;
	1405	dMY_CXT ;
1406	1406	int retval ;
1407	1407	int count ;
1408	1408	/* BerkeleyDB keepDB = CurrentDB ; */

1445	1445	{
1446	1446	#ifdef dTHX
1447	1447	dTHX;
1448		#endif
	1448	#endif
1449	1449	dSP ;
1450		dMY_CXT ;
	1450	dMY_CXT ;
1451	1451	char * pk_dat, * pd_dat ;
1452	1452	int retval ;
1453	1453	int count ;

1500	1500	retval = POPi ;
1501	1501
1502	1502	PUTBACK ;
1503
	1503
1504	1504	if (retval != DB_DONOTINDEX)
1505	1505	{
1506	1506	/* retrieve the secondary key */

1550	1550	} else {
1551	1551	croak("Not an array reference");
1552	1552	}
1553		} else
	1553	} else
1554	1554	#endif
1555	1555	{
1556	1556	skey_ptr = SvPV(skey_SV, skey_len);

1574	1574	{
1575	1575	#ifdef dTHX
1576	1576	dTHX;
1577		#endif
	1577	#endif
1578	1578	dSP ;
1579		dMY_CXT ;
	1579	dMY_CXT ;
1580	1580	char * pk_dat, * pd_dat ;
1581	1581	int retval ;
1582	1582	int count ;

1627	1627	retval = POPi ;
1628	1628
1629	1629	PUTBACK ;
1630
	1630
1631	1631	/* retrieve the secondary key */
1632	1632	DBT_clear(*skey);
1633	1633
1634	1634	if (retval != DB_DONOTINDEX)
1635	1635	{
1636		Value = GetRecnoKey(getCurrentDB, SvIV(skey_SV)) ;
	1636	Value = GetRecnoKey(getCurrentDB, SvIV(skey_SV)) ;
1637	1637	skey->flags = DB_DBT_APPMALLOC;
1638	1638	skey->size = (int)sizeof(db_recno_t);
1639	1639	skey->data = (char*)safemalloc(skey->size);

1650	1650
1651	1651	#ifdef AT_LEAST_DB_4_8
1652	1652
1653		typedef int (bt_compress_fcn_type)(DB db, const DBT *prevKey,
	1653	typedef int (bt_compress_fcn_type)(DB db, const DBT *prevKey,
1654	1654	const DBT prevData, const DBT key, const DBT data, DBT dest);
1655	1655
1656		typedef int (bt_decompress_fcn_type)(DB db, const DBT *prevKey,
	1656	typedef int (bt_decompress_fcn_type)(DB db, const DBT *prevKey,
1657	1657	const DBT prevData, DBT compressed, DBT destKey, DBT destData);
1658	1658
1659	1659	#endif /* AT_LEAST_DB_4_8 */

1667	1667	{
1668	1668	#ifdef dTHX
1669	1669	dTHX;
1670		#endif
	1670	#endif
1671	1671	dSP ;
1672		dMY_CXT ;
	1672	dMY_CXT ;
1673	1673	char * k_dat, * d_dat, * f_dat;
1674	1674	int retval ;
1675	1675	int count ;

1754	1754	{
1755	1755	#ifdef dTHX
1756	1756	dTHX;
1757		#endif
	1757	#endif
1758	1758	dSP ;
1759		dMY_CXT ;
	1759	dMY_CXT ;
1760	1760	char * k_dat, * d_dat, * f_dat;
1761	1761	int retval ;
1762	1762	int count ;

1820	1820	if (*changed)
1821	1821	{
1822	1822	DBT_clear(*data);
1823		Value = GetRecnoKey(getCurrentDB, SvIV(data_sv)) ;
	1823	Value = GetRecnoKey(getCurrentDB, SvIV(data_sv)) ;
1824	1824	data->flags = DB_DBT_APPMALLOC;
1825	1825	data->size = (int)sizeof(db_recno_t);
1826	1826	data->data = (char*)safemalloc(data->size);

1845	1845	{
1846	1846	#ifdef dTHX
1847	1847	dTHX;
1848		#endif
	1848	#endif
1849	1849	SV * sv;
1850	1850
1851	1851	Trace(("In errcall_cb \n")) ;

1892	1892	{
1893	1893	#ifdef dTHX
1894	1894	dTHX;
1895		#endif
	1895	#endif
1896	1896	SV ** svp;
1897	1897	svp = hv_fetch(hash, key, strlen(key), FALSE);
1898	1898

1911	1911	{
1912	1912	#ifdef dTHX
1913	1913	dTHX;
1914		#endif
	1914	#endif
1915	1915	HV * hv = perl_get_hv(hash, TRUE);
1916	1916	(void) hv_delete(hv, (char*)&key, sizeof(key), G_DISCARD);
1917	1917	}

1921	1921	{
1922	1922	#ifdef dTHX
1923	1923	dTHX;
1924		#endif
	1924	#endif
1925	1925	HV * hv = perl_get_hv(hash, TRUE);
1926	1926	(void)hv_store(hv, (char*)&key, sizeof(key), newSViv(value), 0);
1927	1927	/* printf("hv_store returned %d\n", ret) ; */

1932	1932	{
1933	1933	#ifdef dTHX
1934	1934	dTHX;
1935		#endif
	1935	#endif
1936	1936	hv_store(hash, key, strlen(key), newSViv(value), 0);
1937	1937	}
1938	1938

1949	1949	{
1950	1950	#ifdef dTHX
1951	1951	dTHX;
1952		#endif
1953		dMY_CXT ;
	1952	#endif
	1953	dMY_CXT ;
1954	1954	if (db->recno_or_queue) {
1955		Value = GetRecnoKey(db, SvIV(sv)) ;
1956		key->data = & Value;
	1955	Value = GetRecnoKey(db, SvIV(sv)) ;
	1956	key->data = & Value;
1957	1957	key->size = (int)sizeof(db_recno_t);
1958	1958	}
1959	1959	else {

1968	1968	SV * ref,
1969	1969	SV * ref_dbenv ,
1970	1970	BerkeleyDB__Env dbenv ,
1971		BerkeleyDB__Txn txn,
	1971	BerkeleyDB__Txn txn,
1972	1972	const char * file,
1973	1973	const char * subname,
1974	1974	DBTYPE type,

1982	1982	{
1983	1983	#ifdef dTHX
1984	1984	dTHX;
1985		#endif
	1985	#endif
1986	1986	DB_ENV * env = NULL ;
1987	1987	BerkeleyDB RETVAL = NULL ;
1988	1988	DB * dbp ;

1993	1993	Trace(("_db_open(dbenv[%p] ref_dbenv [%p] file[%s] subname [%s] type[%d] flags[%d] mode[%d]\n",
1994	1994	dbenv, ref_dbenv, file, subname, type, flags, mode)) ;
1995	1995
1996
	1996
1997	1997	if (dbenv)
1998	1998	env = dbenv->Env ;
1999	1999

2075	2075	if (password)
2076	2076	{
2077	2077	Status = dbp->set_encrypt(dbp, password, enc_flags);
2078		Trace(("DB->set_encrypt passwd = %s, flags %d returned %s\n",
	2078	Trace(("DB->set_encrypt passwd = %s, flags %d returned %s\n",
2079	2079	password, enc_flags,
2080	2080	my_db_strerror(Status))) ;
2081	2081	if (Status)
2082	2082	return RETVAL ;
2083	2083	}
2084		#endif
	2084	#endif
2085	2085
2086	2086	if (info->re_source) {
2087	2087	Status = dbp->set_re_source(dbp, info->re_source) ;

2235	2235	#else
2236	2236	{
2237	2237	Status = dbp->set_blob_threshold(dbp, info->blob_threshold, 0);
2238		Trace(("ENV->set_blob_threshold value = %d returned %s\n",
	2238	Trace(("ENV->set_blob_threshold value = %d returned %s\n",
2239	2239	info->blob_threshold,
2240	2240	my_db_strerror(Status))) ;
2241	2241	if (Status)

2387	2387	RETVAL = env->Status = env->Env->dbremove(env->Env, txn->txn, db, subdb, flags);
2388	2388	#else
2389	2389	softCrash("transactional db_remove requires Berkeley DB 4.1 or better");
2390		#endif
	2390	#endif
2391	2391	} else {
2392	2392	if (env)
2393	2393	dbenv = env->Env ;

2440	2440	RETVAL = db_create(&dbp, dbenv, 0) ;
2441	2441	if (RETVAL == 0) {
2442	2442	RETVAL = dbp->verify(dbp, db, subdb, ofh, flags) ;
2443		#ifndef AT_LEAST_DB_4_2
2444		dbp->close(dbp, 0) ;
	2443	#ifndef AT_LEAST_DB_4_2
	2444	dbp->close(dbp, 0) ;
2445	2445	#endif
2446	2446	}
2447		if (outfile)
	2447	if (outfile)
2448	2448	fclose(ofh);
2449	2449	}
2450	2450	#endif

2527	2527	env->set_alloc(env, safemalloc, MyRealloc, safefree) ;
2528	2528	env->set_errcall(env, db_errcall_cb) ;
2529	2529	}
2530		#endif
	2530	#endif
2531	2531	}
2532	2532	OUTPUT:
2533	2533	RETVAL

2602	2602	_db_appinit(self, ref, errfile=NULL)
2603	2603	char * self
2604	2604	SV * ref
2605		SV * errfile
	2605	SV * errfile
2606	2606	PREINIT:
2607	2607	dMY_CXT;
2608	2608	CODE:

2736	2736	Trace(("copying errprefix\n" )) ;
2737	2737	RETVAL->ErrPrefix = newSVsv(errprefix) ;
2738	2738	SvPOK_only(RETVAL->ErrPrefix) ;
2739		}
	2739	}
2740	2740	if (RETVAL->ErrPrefix)
2741	2741	RETVAL->Env->db_errpfx = SvPVX(RETVAL->ErrPrefix) ;
2742	2742

2812	2812	Trace(("set_lg_dir [%s] returned %s\n", log_dir,
2813	2813	my_db_strerror(status)));
2814	2814	}
2815		#endif
	2815	#endif
2816	2816	#ifdef AT_LEAST_DB_4_4
2817	2817	if (status == 0 && log_filemode) {
2818	2818	status = env->set_lg_filemode(env, log_filemode) ;

2825	2825	Trace(("set_cachesize [%d] returned %s\n",
2826	2826	cachesize, my_db_strerror(status)));
2827	2827	}
2828
	2828
2829	2829	if (status == 0 && lk_detect) {
2830	2830	status = env->set_lk_detect(env, lk_detect) ;
2831	2831	Trace(("set_lk_detect [%d] returned %s\n",

2868	2868	if (enc_passwd && status == 0)
2869	2869	{
2870	2870	status = env->set_encrypt(env, enc_passwd, enc_flags);
2871		Trace(("ENV->set_encrypt passwd = %s, flags %d returned %s\n",
	2871	Trace(("ENV->set_encrypt passwd = %s, flags %d returned %s\n",
2872	2872	enc_passwd, enc_flags,
2873	2873	my_db_strerror(status))) ;
2874	2874	}
2875		#endif
	2875	#endif
2876	2876	#if ! defined(AT_LEAST_DB_5_1)
2877	2877	#ifdef AT_LEAST_DB_4
2878	2878	/* set the server */

2962	2962	SetValue_iv(mode, "Mode") ;
2963	2963	env->set_errcall(env, db_errcall_cb) ;
2964	2964	RETVAL->active = TRUE ;
2965		RETVAL->cds_enabled = ((flags & DB_INIT_CDB) != 0 ? TRUE : FALSE) ;
	2965	RETVAL->cds_enabled = ((flags & DB_INIT_CDB) != 0 ? TRUE : FALSE) ;
2966	2966	#ifdef IS_DB_3_0_x
2967	2967	status = (env->open)(env, home, config, flags, mode) ;
2968	2968	#else /* > 3.0 */

3007	3007	else
3008	3008	RETVAL = NULL;
3009	3009	OUTPUT:
3010		RETVAL
	3010	RETVAL
3011	3011
3012	3012
3013	3013	void

3133	3133	#if DB_VERSION_MAJOR == 2
3134	3134	# define env_txn_checkpoint(e,k,m,f) txn_checkpoint(e->Env->tx_info, k, m)
3135	3135	#else /* DB 3.0 or better */
3136		# ifdef AT_LEAST_DB_4
	3136	# ifdef AT_LEAST_DB_4
3137	3137	# define env_txn_checkpoint(e,k,m,f) e->Env->txn_checkpoint(e->Env, k, m, f)
3138	3138	# else
3139	3139	# ifdef AT_LEAST_DB_3_1

3348	3348	softCrash("$env->get_shm_key needs Berkeley DB 4.2 or better") ;
3349	3349	#else
3350	3350	RETVAL = env->Env->get_shm_key(env->Env, &id);
3351		#endif
	3351	#endif
3352	3352	OUTPUT:
3353	3353	RETVAL
3354	3354	id

3391	3391	int
3392	3392	set_lg_filemode(env, filemode)
3393	3393	BerkeleyDB::Env env
3394		u_int32_t filemode
	3394	u_int32_t filemode
3395	3395	PREINIT:
3396	3396	dMY_CXT;
3397	3397	INIT:

3728	3728	DualType
3729	3729	set_region_dir(env, dir)
3730	3730	BerkeleyDB::Env env
3731		const char* dir
	3731	const char* dir
3732	3732	PREINIT:
3733	3733	dMY_CXT;
3734	3734	CODE:

3874	3874	DB_HASH_STAT * stat ;
3875	3875	#ifdef AT_LEAST_DB_4_3
3876	3876	db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
3877		#else
	3877	#else
3878	3878	#ifdef AT_LEAST_DB_3_3
3879	3879	db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
3880	3880	#else

4047	4047	db->prefix = newSVsv(sv) ;
4048	4048	}
4049	4049
4050		RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
	4050	RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
4051	4051	DB_BTREE, flags, mode, &info, enc_passwd, enc_flags, hash) ;
4052	4052	}
4053	4053	OUTPUT:

4068	4068	DB_BTREE_STAT * stat ;
4069	4069	#ifdef AT_LEAST_DB_4_3
4070	4070	db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
4071		#else
	4071	#else
4072	4072	#ifdef AT_LEAST_DB_3_3
4073	4073	db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
4074	4074	#else

4179	4179	SetValue_pv(info.blob_dir, "BlobDir", char*) ;
4180	4180	#endif
4181	4181	ZMALLOC(db, BerkeleyDB_type) ;
4182		RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
	4182	RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
4183	4183	DB_HEAP, flags, mode, &info, enc_passwd, enc_flags, hash) ;
4184	4184	#endif
4185	4185	}

4249	4249	db->array_base = (db->array_base == 0 ? 1 : 0) ;
4250	4250	#endif /* ALLOW_RECNO_OFFSET */
4251	4251
4252		RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
	4252	RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
4253	4253	DB_RECNO, flags, mode, &info, enc_passwd, enc_flags, hash) ;
4254	4254	}
4255	4255	OUTPUT:

4317	4317	db->array_base = (db->array_base == 0 ? 1 : 0) ;
4318	4318	#endif /* ALLOW_RECNO_OFFSET */
4319	4319
4320		RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
	4320	RETVAL = my_db_open(db, ref, ref_dbenv, dbenv, txn, file, subname,
4321	4321	DB_QUEUE, flags, mode, &info, enc_passwd, enc_flags, hash) ;
4322	4322	#endif
4323	4323	}

4341	4341	DB_QUEUE_STAT * stat ;
4342	4342	#ifdef AT_LEAST_DB_4_3
4343	4343	db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, flags) ;
4344		#else
	4344	#else
4345	4345	#ifdef AT_LEAST_DB_3_3
4346	4346	db->Status = ((db->dbp)->stat)(db->dbp, &stat, flags) ;
4347	4347	#else

4450	4450	if (ix == 1 && db->cds_enabled) {
4451	4451	#ifdef AT_LEAST_DB_3
4452	4452	flags \|= DB_WRITECURSOR;
4453		#else
	4453	#else
4454	4454	flags \|= DB_RMW;
4455		#endif
	4455	#endif
4456	4456	}
4457	4457	if ((db->Status = db_cursor(db, db->txn, &cursor, flags)) == 0){
4458	4458	ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;

4806	4806	RETVAL
4807	4807	key if (writeToKey()) OutputKey(ST(1), key) ;
4808	4808	data
4809
	4809
4810	4810	#define db_exists(db, key, flags) \
4811	4811	(db->Status = ((db->dbp)->exists)(db->dbp, db->txn, &key, flags))
4812	4812	DualType

4837	4837	u_int flags
4838	4838	BerkeleyDB::Common db
4839	4839	DBTKEY_B key
4840		DBTKEY_Bpr pkey
	4840	DBTKEY_Bpr pkey
4841	4841	DBT_OPT data
4842	4842	PREINIT:
4843	4843	dMY_CXT;

5040	5040	{
5041	5041	//softCrash("associate_foreign does not support callbacks yet") ;
5042	5042	secondary->associated_foreign = newSVsv(callback) ;
5043		callback_ptr = ( secondary->recno_or_queue
5044		? associate_foreign_cb_recno
	5043	callback_ptr = ( secondary->recno_or_queue
	5044	? associate_foreign_cb_recno
5045	5045	: associate_foreign_cb);
5046	5046	}
5047	5047	secondary->primary_recno_or_queue = db->recno_or_queue ;

5063	5063	SVnull* stop
5064	5064	SVnull* c_data
5065	5065	u_int32_t flags
5066		SVnull* end
	5066	SVnull* end
5067	5067	CODE:
5068	5068	{
5069	5069	#ifndef AT_LEAST_DB_4_4

5102	5102	hash = (HV*) SvRV(c_data) ;
5103	5103	cmpt_p = & cmpt;
5104	5104	cmpt.compact_fillpercent = GetValue_iv(hash,"compact_fillpercent") ;
5105		cmpt.compact_timeout = (db_timeout_t) GetValue_iv(hash, "compact_timeout");
	5105	cmpt.compact_timeout = (db_timeout_t) GetValue_iv(hash, "compact_timeout");
5106	5106	}
5107	5107	RETVAL = (db->dbp)->compact(db->dbp, db->txn, start_p, stop_p, cmpt_p, flags, end_p);
5108	5108	if (RETVAL == 0 && hash) {

5209	5209	/* RETVAL->info ; */
5210	5210	hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
5211	5211	}
5212		#endif
	5212	#endif
5213	5213	}
5214	5214	OUTPUT:
5215	5215	RETVAL

5279	5279	cu_c_get(db, key, data, flags=0)
5280	5280	int flags
5281	5281	BerkeleyDB::Cursor db
5282		DBTKEY_B key
5283		DBT_B data
	5282	DBTKEY_B key
	5283	DBT_B data
5284	5284	PREINIT:
5285	5285	dMY_CXT;
5286	5286	INIT:

5302	5302	int flags
5303	5303	BerkeleyDB::Cursor db
5304	5304	DBTKEY_B key
5305		DBTKEY_Bpr pkey
	5305	DBTKEY_Bpr pkey
5306	5306	DBT_B data
5307	5307	PREINIT:
5308	5308	dMY_CXT;

5321	5321	RETVAL
5322	5322	key if (writeToKey()) OutputKey(ST(1), key) ;
5323	5323	pkey
5324		data
	5324	data
5325	5325
5326	5326
5327	5327

5427	5427	{
5428	5428	Trace(("db_stream [%s]\n", my_db_strerror(db->Status)));
5429	5429	}
5430		#endif
	5430	#endif
5431	5431	}
5432	5432	OUTPUT:
5433	5433	RETVAL

5435	5435	BerkeleyDB::DbStream::Raw
5436	5436	_c_get_db_stream(db, key, cflags, sflags)
5437	5437	BerkeleyDB::Cursor db
5438		DBTKEY_B4Blob key
	5438	DBTKEY_B4Blob key
5439	5439	u_int32_t cflags
5440	5440	u_int32_t sflags
5441	5441	BerkeleyDB::DbStream RETVAL = NULL ;

5451	5451	#else
5452	5452	DBT data;
5453	5453	DB_STREAM * stream = NULL ;
5454		DBT_clear(data);
	5454	DBT_clear(data);
5455	5455	data.flags = DB_DBT_PARTIAL;
5456	5456	db->Status = (db->cursor->c_get)(db->cursor, &key, &data, cflags);
5457	5457	if (db->Status == 0)

5469	5469	{
5470	5470	Trace(("db_stream [%s]\n", my_db_strerror(db->Status)));
5471	5471	}
5472		#endif
	5472	#endif
5473	5473	}
5474	5474	OUTPUT:
5475	5475	RETVAL

5515	5515	DualType
5516	5516	read(db, data, offset, size, flags=0)
5517	5517	BerkeleyDB::DbStream db
5518		DBT_Blob data
	5518	DBT_Blob data
5519	5519	db_off_t offset
5520	5520	u_int32_t size
5521	5521	u_int32_t flags

5647	5647	#if DB_VERSION_MAJOR == 2
5648	5648	# define xx_txn_checkpoint(t,k,m,f) txn_checkpoint(t->env->Env->tx_info, k, m)
5649	5649	#else
5650		# ifdef AT_LEAST_DB_4
	5650	# ifdef AT_LEAST_DB_4
5651	5651	# define xx_txn_checkpoint(e,k,m,f) e->env->Env->txn_checkpoint(e->env->Env, k, m, f)
5652	5652	# else
5653	5653	# ifdef AT_LEAST_DB_3_1

5988	5988	OUTPUT:
5989	5989	RETVAL
5990	5990
5991
	5991
5992	5992	MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common
5993	5993
5994	5994	BerkeleyDB::Sequence

6018	6018	OUTPUT:
6019	6019	RETVAL
6020	6020
6021
	6021
6022	6022	MODULE = BerkeleyDB::Sequence PACKAGE = BerkeleyDB::Sequence PREFIX = seq_
6023
	6023
6024	6024	DualType
6025	6025	open(seq, key, flags=0)
6026	6026	BerkeleyDB::Sequence seq

6051	6051	#ifndef AT_LEAST_DB_4_3
6052	6052	softCrash("$seq->close needs Berkeley DB 4.3.x or better") ;
6053	6053	#else
6054		RETVAL = 0;
	6054	RETVAL = 0;
6055	6055	if (seq->active) {
6056	6056	-- seq->db->open_sequences;
6057	6057	RETVAL = (seq->seq->close)(seq->seq, flags);

6060	6060	#endif
6061	6061	OUTPUT:
6062	6062	RETVAL
6063
	6063
6064	6064	DualType
6065	6065	remove(seq,flags=0)
6066	6066	BerkeleyDB::Sequence seq;

6073	6073	#ifndef AT_LEAST_DB_4_3
6074	6074	softCrash("$seq->remove needs Berkeley DB 4.3.x or better") ;
6075	6075	#else
6076		RETVAL = 0;
	6076	RETVAL = 0;
6077	6077	if (seq->active)
6078	6078	RETVAL = seq->seq->remove(seq->seq, seq->db->txn, flags);
6079	6079	seq->active = FALSE;
6080	6080	#endif
6081	6081	OUTPUT:
6082	6082	RETVAL
6083
	6083
6084	6084	void
6085	6085	DESTROY(seq)
6086	6086	BerkeleyDB::Sequence seq

6111	6111	#endif
6112	6112	OUTPUT:
6113	6113	RETVAL
6114		element
6115
	6114	element
	6115
6116	6116	DualType
6117	6117	get_key(seq, key)
6118	6118	BerkeleyDB::Sequence seq;

6130	6130	#endif
6131	6131	OUTPUT:
6132	6132	RETVAL
6133		key
6134
	6133	key
	6134
6135	6135	DualType
6136	6136	initial_value(seq, low, high=0)
6137	6137	BerkeleyDB::Sequence seq;

6149	6149	#endif
6150	6150	OUTPUT:
6151	6151	RETVAL
6152
	6152
6153	6153	DualType
6154	6154	set_cachesize(seq, size)
6155	6155	BerkeleyDB::Sequence seq;

6166	6166	#endif
6167	6167	OUTPUT:
6168	6168	RETVAL
6169
	6169
6170	6170	DualType
6171	6171	get_cachesize(seq, size)
6172	6172	BerkeleyDB::Sequence seq;

6183	6183	#endif
6184	6184	OUTPUT:
6185	6185	RETVAL
6186		size
	6186	size
6187	6187
6188	6188	DualType
6189	6189	set_flags(seq, flags)

6201	6201	#endif
6202	6202	OUTPUT:
6203	6203	RETVAL
6204
	6204
6205	6205	DualType
6206	6206	get_flags(seq, flags)
6207	6207	BerkeleyDB::Sequence seq;

6218	6218	#endif
6219	6219	OUTPUT:
6220	6220	RETVAL
6221		flags
6222
	6221	flags
	6222
6223	6223	DualType
6224	6224	set_range(seq)
6225	6225	BerkeleyDB::Sequence seq;

6237	6237	{
6238	6238	#ifdef dTHX
6239	6239	dTHX;
6240		#endif
	6240	#endif
6241	6241	SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD\|GV_ADDMULTI) ;
6242	6242	SV * version_sv = perl_get_sv("BerkeleyDB::db_version", GV_ADD\|GV_ADDMULTI) ;
6243	6243	SV * ver_sv = perl_get_sv("BerkeleyDB::db_ver", GV_ADD\|GV_ADDMULTI) ;

6266	6266	empty.flags = 0 ;
6267	6267
6268	6268	}
6269

+6

-0

Changes less more

0	0	Revision history for Perl extension BerkeleyDB.
	1
	2	0.65 13 May 2022
	3
	4	* Update to license wording
	5	Fri May 13 07:50:38 2022 +0100
	6	0fb21f12d1938f0cd5c3cfe2f674f0c41863fb55
1	7
2	8	0.64 17 September 2020
3	9

+1

-1

META.json less more

42	42	"web" : "https://github.com/pmqs/BerkeleyDB"
43	43	}
44	44	},
45		"version" : "0.64",
	45	"version" : "0.65",
46	46	"x_serialization_backend" : "JSON::PP version 4.02"
47	47	}

+1

-1

META.yml less more

20	20	bugtracker: https://github.com/pmqs/BerkeleyDB/issues
21	21	homepage: https://github.com/pmqs/BerkeleyDB
22	22	repository: git://github.com/pmqs/BerkeleyDB.git
23		version: '0.64'
	23	version: '0.65'
24	24	x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

+16

-16

Makefile.PL less more

53	53	WriteMakefile(
54	54	NAME => 'BerkeleyDB',
55	55	LIBS => ["-L${LIB_DIR} $LIBS"],
56		#MAN3PODS => {}, # Pods will be built by installman.
	56	#MAN3PODS => {}, # Pods will be built by installman.
57	57	INC => "-I$INC_DIR",
58	58	VERSION_FROM => 'BerkeleyDB.pm',
59	59	XSPROTOARG => '-noprototypes',
60	60	DEFINE => "$OS2 $WALL $TRACE",
61	61	#'macro' => { INSTALLDIRS => 'perl' },
62		'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'},
	62	'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'},
63	63	($] >= 5.005
64	64	? (ABSTRACT_FROM => 'BerkeleyDB.pod',
65	65	AUTHOR => 'Paul Marquess <pmqs@cpan.org>')
66	66	: ()
67	67	),
68		((ExtUtils::MakeMaker->VERSION() gt '6.30')
69		? ('LICENSE' => 'perl')
	68	((ExtUtils::MakeMaker->VERSION() gt '6.30')
	69	? ('LICENSE' => 'perl')
70	70	: ()
71	71	),
72	72
73		( eval { ExtUtils::MakeMaker->VERSION(6.46) }
	73	( eval { ExtUtils::MakeMaker->VERSION(6.46) }
74	74	? ( META_MERGE => {
75
	75
76	76	"meta-spec" => { version => 2 },
77
	77
78	78	resources => {
79
	79
80	80	bugtracker => {
81	81	web => 'https://github.com/pmqs/BerkeleyDB/issues'
82	82	},

87	87	type => 'git',
88	88	url => 'git://github.com/pmqs/BerkeleyDB.git',
89	89	web => 'https://github.com/pmqs/BerkeleyDB',
90		},
	90	},
91	91	},
92		}
93		)
	92	}
	93	)
94	94	: ()
95	95	),
96	96

103	103	my $path = shift ;
104	104
105	105	return undef
106		if $path =~ /(~\|\.bak)$/ \|\|
	106	if $path =~ /(~\|\.bak)$/ \|\|
107	107	$path =~ /^\..*\.swp$/ ;
108	108
109		return $path;
	109	return $path;
110	110	}
111	111
112
	112
113	113	sub MY::postamble {
114	114	'
115	115	$(NAME).pod: $(NAME).pod.P t/examples.t.T t/examples3.t.T mkpod

118	118	$(NAME).xs: typemap
119	119	$(TOUCH) $(NAME).xs
120	120
121		Makefile: config.in
	121	Makefile: config.in
122	122
123	123
124	124	' ;

162	162
163	163	# check parsed values
164	164	my @missing = () ;
165		die "The following keys are missing from $CONFIG file: [@missing]\n"
	165	die "The following keys are missing from $CONFIG file: [@missing]\n"
166	166	if @missing = keys %Parsed ;
167	167
168	168	$INC_DIR = $ENV{'BERKELEYDB_INCLUDE'} \|\| $Info{'INCLUDE'} ;

+6

-6

README less more

0	0	BerkeleyDB
1	1
2		Version 0.64
3
4		17th August 2020
5
6
7		Copyright (c) 1997-2020 Paul Marquess. All rights reserved. This
	2	Version 0.65
	3
	4	13th May 2022
	5
	6
	7	Copyright (c) 1997-2022 Paul Marquess. All rights reserved. This
8	8	program is free software; you can redistribute it and/or modify
9	9	it under the same terms as Perl itself.
10	10

+1

-1

Todo less more

27	27
28	28	* allow recno to allow base offset for arrays to be either 0 or 1.
29	29
30		* when duplicate keys are enabled, allow db_put($key, [$val1, $val2,...])
	30	* when duplicate keys are enabled, allow db_put($key, [$val1, $val2,...])
31	31
32	32
33	33	2.x -> 3.x Upgrade

+1

-1

config.in less more

30	30	# Berkeley DB library from libdb.a to libdb-2.6.4.a and change the
31	31	# DBNAME line below to look like this:
32	32	#
33		# DBNAME = -ldb-2.6.4
	33	# DBNAME = -ldb-2.6.4
34	34	#
35	35	# Note: If you are building this module with Win32, -llibdb will be
36	36	# used by default.

+1

-1

dbinfo less more

6	6	# Version: 1.07
7	7	# Date 2nd April 2011
8	8	#
9		# Copyright (c) 1998-2020 Paul Marquess. All rights reserved.
	9	# Copyright (c) 1998-2022 Paul Marquess. All rights reserved.
10	10	# This program is free software; you can redistribute it and/or
11	11	# modify it under the same terms as Perl itself.
12	12

+6

-0

debian/changelog less more

	0	libberkeleydb-perl (0.65-1) UNRELEASED; urgency=low
	1
	2	* New upstream release.
	3
	4	-- Debian Janitor <janitor@jelmer.uk> Wed, 14 Dec 2022 22:43:47 -0000
	5
0	6	libberkeleydb-perl (0.64-2) unstable; urgency=medium
1	7
2	8	* Enable the autopkgtest-pkg-perl test suite.

+5

-5

mkconsts.pl less more

0	0	#!/usr/bin/perl
1	1
2		use ExtUtils::Constant qw(WriteConstants);
	2	use ExtUtils::Constant qw(WriteConstants);
3	3
4	4	use constant DEFINE => 'define' ;
5	5	use constant STRING => 'string' ;

1176	1176	my $str = shift ;
1177	1177	my ($major, $minor, $patch) = split /\./, $str ;
1178	1178
1179		my $macro =
	1179	my $macro =
1180	1180	"#if (DB_VERSION_MAJOR > $major) \|\| \\\n" .
1181	1181	" (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR > $minor) \|\| \\\n" .
1182	1182	" (DB_VERSION_MAJOR == $major && DB_VERSION_MINOR == $minor && \\\n" .

1231	1231	if ( /^\s*$START_re/ )
1232	1232	{
1233	1233	# skip to the end marker.
1234		while (<IN>)
	1234	while (<IN>)
1235	1235	{ last OUTER if /^\s*$END_re/ }
1236	1236	}
1237	1237	print OUT ;
1238	1238	}
1239
	1239
1240	1240	print OUT "$START\n";
1241	1241	foreach my $key (sort keys %constants)
1242	1242	{

1244	1244	print OUT "\t$key\n";
1245	1245	}
1246	1246	print OUT "\t$END\n";
1247
	1247
1248	1248	while (<IN>)
1249	1249	{
1250	1250	print OUT ;

+5

-5

mkpod less more

9	9	# Tagged source files end with .T
10	10	# Output from the code ends with .O
11	11	# Pre-Pod file ends with .P
12		#
	12	#
13	13	# Tags
14	14	#
15	15	# ## BEGIN tagname

34	34	{
35	35	# Skip blank & comment lines
36	36	next if /^\s$/ \|\| /^\s#/ ;
37
38		#
	37
	38	#
39	39	($name, $expand) = split (/\t+/, $_, 2) ;
40	40
41	41	$expand =~ s/^\s*// ;

129	129	{
130	130	warn "No code insert '$1' available\n"
131	131	unless $Section{$1} ;
132
	132
133	133	print "Expanding section $1\n" if $Verbose ;
134	134	print POD $Section{$1} ;
135	135	}

139	139	print POD $line ;
140	140	}
141	141	}
142
	142
143	143	close PPOD ;
144	144	close POD ;
145	145	}

+25

-26

scan.pl less more

0	0	#!/usr/local/bin/perl
1	1
2		my $ignore_re = '^(' . join("\|",
	2	my $ignore_re = '^(' . join("\|",
3	3	qw(
4	4	_
5	5	[a-z]

44	44	my $file = readFile($inc) ;
45	45	StripCommentsAndStrings($file) ;
46	46	my $result = scan($name, $file) ;
47		print "\n\t#########\n\t# $name\n\t#########\n\n$result"
	47	print "\n\t#########\n\t# $name\n\t#########\n\n$result"
48	48	if $result;
49	49	}
50	50	exit ;

59	59	my $result = "" ;
60	60
61	61	if (1) {
62		# Preprocess all tri-graphs
	62	# Preprocess all tri-graphs
63	63	# including things stuck in quoted string constants.
64	64	$file =~ s/\?\?=/#/g; # \| ??=\| #\|
65	65	$file =~ s/\?\?\!/\|/g; # \| ??!\| \|\|

71	71	$file =~ s/\?\?</{/g; # \| ??<\| {\|
72	72	$file =~ s/\?\?>/}/g; # \| ??>\| }\|
73	73	}
74
75		while ( $file =~ /^\s#\sdefine\s+([\$\w]+)\b(?!\()\s(.)/gm )
	74
	75	while ( $file =~ /^\s#\sdefine\s+([\$\w]+)\b(?!\()\s(.)/gm )
76	76	{
77	77	my $def = $1;
78	78	my $rest = $2;
79	79	my $ignore = 0 ;
80
	80
81	81	$ignore = 1 if $ignore_def{$def} \|\| $def =~ /$ignore_re/o ;
82
	82
83	83	# Cannot do: (-1) and ((LHANDLE)3) are OK:
84	84	#print("Skip non-wordy $def => $rest\n"),
85
	85
86	86	$rest =~ s/\s*$//;
87	87	#next if $rest =~ /[^\w\$]/;
88
	88
89	89	#print "Matched $_ ($def)\n" ;
90	90
91	91	next if $before{$def} ++ ;
92
	92
93	93	if ($ignore)
94	94	{ $seen_define{$def} = 'IGNORE' }
95		elsif ($rest =~ /"/)
	95	elsif ($rest =~ /"/)
96	96	{ $seen_define{$def} = 'STRING' }
97	97	else
98	98	{ $seen_define{$def} = 'DEFINE' }
99	99	}
100
	100
101	101	foreach $define (sort keys %seen_define)
102		{
	102	{
103	103	my $out = $filler ;
104	104	substr($out,0, length $define) = $define;
105	105	$result .= "\t$out => $seen_define{$define},\n" ;
106	106	}
107
	107
108	108	while ($file =~ /\btypedef\s+enum\s{(.?)}\s*(\w+)/gs )
109	109	{
110	110	my $enum = $1 ;
111	111	my $name = $2 ;
112	112	my $ignore = 0 ;
113
	113
114	114	$ignore = 1 if $ignore_enums{$name} ;
115
	115
116	116	#$enum =~ s/\s=\s\S+\s(,?)\s\n/$1/g;
117	117	$enum =~ s/^\s*//;
118	118	$enum =~ s/\s*$//;
119
	119
120	120	my @tokens = map { s/\s=.// ; $_} split /\s,\s/, $enum ;
121	121	my @new = grep { ! $Enums{$_}++ } @tokens ;
122	122

159	159	)* ## 0-or-more things which don't start with /
160	160	## but do end with '*'
161	161	/ ## End of /* ... */ comment
162
	162
163	163	\| ## OR C++ Comment
164		// ## Start of C++ comment //
	164	// ## Start of C++ comment //
165	165	[^\n]* ## followed by 0-or-more non end of line characters
166	166
167	167	\| ## OR various things which aren't comments:
168
	168
169	169	(
170	170	" ## Start of " ... " string
171	171	(

174	174	[^"\\] ## Non "\
175	175	)*
176	176	" ## End of " ... " string
177
	177
178	178	\| ## OR
179
	179
180	180	' ## Start of ' ... ' string
181	181	(
182	182	\\. ## Escaped char

184	184	[^'\\] ## Non '\
185	185	)*
186	186	' ## End of ' ... ' string
187
	187
188	188	\| ## OR
189
	189
190	190	. ## Anything other char
191	191	[^/"'\\]* ## Chars which doesn't start a comment, string or escape
192	192	)

235	235	$A == $B or return $A <=> $B ;
236	236	}
237	237	return 0;
238		}
	238	}
239	239
240	240	__END__
241

+1

-1

t/000prereq.t less more

20	20
21	21	plan tests => 1 + $extra ;
22	22
23		use_ok('BerkeleyDB', '0.64');
	23	use_ok('BerkeleyDB', '0.65');
24	24	}
25	25
26	26	if (defined $BerkeleyDB::VERSION)

+5

-6

t/blob.t less more

2	2	use strict ;
3	3
4	4	use lib 't';
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7	use Test::More;
8	8

38	38	my $lexd = new LexDir $home ;
39	39	my $threshold = 1234 ;
40	40
41		ok my $env = new BerkeleyDB::Env
	41	ok my $env = new BerkeleyDB::Env
42	42	Flags => DB_CREATE\|DB_INIT_MPOOL,
43		#@StdErrFile,
	43	#@StdErrFile,
44	44	BlobDir => $home,
45	45	Home => $home ;
46	46
47		ok my $db = new $TYPE Filename => $Dfile,
	47	ok my $db = new $TYPE Filename => $Dfile,
48	48	Env => $env,
49	49	BlobThreshold => $threshold,
50	50	Flags => DB_CREATE ;

101	101	ok $dbstream->write($newData) == 0 , "write";
102	102
103	103	substr($bigData, 0, length($newData)) = $newData;
104
	104
105	105	my $new1;
106	106	ok $dbstream->read($new, 0, 5) == 0 , "read";
107	107	is $new, "hello";

162	162	is $d2, $smallData;
163	163
164	164	}
165

+57

-58

t/btree.t less more

2	2	use strict ;
3	3
4	4	use lib 't';
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7	use Test::More;
8	8

24	24	ok $@ =~ /unknown key value$s$ Stupid/ ;
25	25
26	26	eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
27		ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
	27	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
28	28	or print "# $@" ;
29	29
30	30	eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ;

43	43	{
44	44	my $lex = new LexFile $Dfile ;
45	45
46		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	46	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
47	47	-Flags => DB_CREATE ;
48	48
49	49	# Add a k/v pair

60	60	ok $db->db_del("some key") == 0 ;
61	61	ok $db->db_get("some key", $value) == DB_NOTFOUND ;
62	62	ok $db->status() == DB_NOTFOUND ;
63		ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
	63	ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
64	64	or diag "Status is [" . $db->status() . "]";
65	65
66	66	ok $db->db_sync() == 0 ;

100	100
101	101	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
102	102	@StdErrFile, -Home => $home ;
103		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	103	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
104	104	-Env => $env,
105	105	-Flags => DB_CREATE ;
106	106

116	116	undef $env ;
117	117	}
118	118
119
	119
120	120	{
121	121	# cursors
122	122
123	123	my $lex = new LexFile $Dfile ;
124	124	my %hash ;
125	125	my ($k, $v) ;
126		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	126	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
127	127	-Flags => DB_CREATE ;
128		#print "[$db] [$!] $BerkeleyDB::Error\n" ;
	128	#print "[$db] [$!] $BerkeleyDB::Error\n" ;
129	129
130	130	# create some data
131	131	my %data = (

148	148	my $extras = 0 ;
149	149	# sequence forwards
150	150	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
151		if ( $copy{$k} eq $v )
	151	if ( $copy{$k} eq $v )
152	152	{ delete $copy{$k} }
153	153	else
154	154	{ ++ $extras }

165	165	for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
166	166	$status == 0 ;
167	167	$status = $cursor->c_get($k, $v, DB_PREV)) {
168		if ( $copy{$k} eq $v )
	168	if ( $copy{$k} eq $v )
169	169	{ delete $copy{$k} }
170	170	else
171	171	{ ++ $extras }

187	187	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
188	188
189	189	}
190
	190
191	191	{
192	192	# Tied Hash interface
193	193

252	252	my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
253	253	my $value ;
254	254	my (%h, %g, %k) ;
255		my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
256		ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	255	my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
	256	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
257	257	-Compare => sub { $_[0] <=> $_[1] },
258	258	-Flags => DB_CREATE ;
259	259
260		ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	260	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
261	261	-Compare => sub { $_[0] cmp $_[1] },
262	262	-Flags => DB_CREATE ;
263	263
264		ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
	264	ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
265	265	-Compare => sub { length $_[0] <=> length $_[1] },
266	266	-Flags => DB_CREATE ;
267	267
268	268	my @srt_1 ;
269	269	{ local $^W = 0 ;
270		@srt_1 = sort { $a <=> $b } @Keys ;
	270	@srt_1 = sort { $a <=> $b } @Keys ;
271	271	}
272	272	my @srt_2 = sort { $a cmp $b } @Keys ;
273	273	my @srt_3 = sort { length $a <=> length $b } @Keys ;
274	274
275	275	foreach (@Keys) {
276	276	local $^W = 0 ;
277		$h{$_} = 1 ;
	277	$h{$_} = 1 ;
278	278	$g{$_} = 1 ;
279	279	$k{$_} = 1 ;
280	280	}

289	289	my $lex = new LexFile $Dfile, $Dfile2, $Dfile3 ;
290	290	my $value ;
291	291	my (%h, %g, %k) ;
292		my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ;
293		my @Values = qw( 1 0 3 dd x abc 0 ) ;
294		ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	292	my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ;
	293	my @Values = qw( 1 0 3 dd x abc 0 ) ;
	294	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
295	295	-Compare => sub { $_[0] <=> $_[1] },
296	296	-Property => DB_DUP,
297	297	-Flags => DB_CREATE ;
298	298
299		ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	299	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
300	300	-Compare => sub { $_[0] cmp $_[1] },
301	301	-Property => DB_DUP,
302	302	-Flags => DB_CREATE ;
303	303
304		ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
	304	ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
305	305	-Compare => sub { length $_[0] <=> length $_[1] },
306	306	-Property => DB_DUP,
307	307	-Flags => DB_CREATE ;
308	308
309	309	my @srt_1 ;
310	310	{ local $^W = 0 ;
311		@srt_1 = sort { $a <=> $b } @Keys ;
	311	@srt_1 = sort { $a <=> $b } @Keys ;
312	312	}
313	313	my @srt_2 = sort { $a cmp $b } @Keys ;
314	314	my @srt_3 = sort { length $a <=> length $b } @Keys ;

316	316	foreach (@Keys) {
317	317	local $^W = 0 ;
318	318	my $value = shift @Values ;
319		$h{$_} = $value ;
	319	$h{$_} = $value ;
320	320	$g{$_} = $value ;
321	321	$k{$_} = $value ;
322	322	}

358	358	my $lex = new LexFile $Dfile, $Dfile2;
359	359	my $value ;
360	360	my (%h, %g) ;
361		my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
362		my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
363		ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	361	my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
	362	my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
	363	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
364	364	-Compare => sub { $_[0] <=> $_[1] },
365	365	-DupCompare => sub { $_[0] cmp $_[1] },
366	366	-Property => DB_DUP,
367	367	-Flags => DB_CREATE ;
368	368
369		ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	369	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
370	370	-Compare => sub { $_[0] cmp $_[1] },
371	371	-DupCompare => sub { $_[0] <=> $_[1] },
372	372	-Property => DB_DUP,
373
374
375
	373
	374
	375
376	376	-Flags => DB_CREATE ;
377	377
378	378	my @srt_1 ;
379	379	{ local $^W = 0 ;
380		@srt_1 = sort { $a <=> $b } @Keys ;
	380	@srt_1 = sort { $a <=> $b } @Keys ;
381	381	}
382	382	my @srt_2 = sort { $a cmp $b } @Keys ;
383	383
384	384	foreach (@Keys) {
385	385	local $^W = 0 ;
386	386	my $value = shift @Values ;
387		$h{$_} = $value ;
	387	$h{$_} = $value ;
388	388	$g{$_} = $value ;
389	389	}
390	390

400	400	my $lex = new LexFile $Dfile;
401	401	my %hh ;
402	402
403		ok my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
	403	ok my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
404	404	-DupCompare => sub { $_[0] cmp $_[1] },
405	405	-Property => DB_DUP,
406	406	-Flags => DB_CREATE ;

410	410	$hh{'Wall'} = 'Brick' ; # Note the duplicate key
411	411	$hh{'Smith'} = 'John' ;
412	412	$hh{'mouse'} = 'mickey' ;
413
	413
414	414	# first work in scalar context
415	415	ok scalar $YY->get_dup('Unknown') == 0 ;
416	416	ok scalar $YY->get_dup('Smith') == 1 ;
417	417	ok scalar $YY->get_dup('Wall') == 3 ;
418
	418
419	419	# now in list context
420	420	my @unknown = $YY->get_dup('Unknown') ;
421	421	ok "@unknown" eq "" ;
422
	422
423	423	my @smith = $YY->get_dup('Smith') ;
424	424	ok "@smith" eq "John" ;
425
	425
426	426	{
427	427	my @wall = $YY->get_dup('Wall') ;
428	428	my %wall ;
429	429	@wall{@wall} = @wall ;
430	430	ok (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
431	431	}
432
	432
433	433	# hash
434	434	my %unknown = $YY->get_dup('Unknown', 1) ;
435	435	ok keys %unknown == 0 ;
436
	436
437	437	my %smith = $YY->get_dup('Smith', 1) ;
438	438	ok keys %smith == 1 && $smith{'John'} ;
439
	439
440	440	my %wall = $YY->get_dup('Wall', 1) ;
441		ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
	441	ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
442	442	&& $wall{'Brick'} == 1 ;
443
	443
444	444	undef $YY ;
445	445	untie %hh ;
446	446

460	460	ok $value eq "some value" ;
461	461
462	462	}
463
	463
464	464	{
465	465	# partial
466	466	# check works via API

544	544
545	545	{
546	546	# partial
547		# check works via tied hash
	547	# check works via tied hash
548	548
549	549	my $lex = new LexFile $Dfile ;
550	550	my %hash ;

633	633	ok ((my $Z = $txn->txn_commit()) == 0) ;
634	634	ok $txn = $env->txn_begin() ;
635	635	$db1->Txn($txn);
636
	636
637	637	# create some data
638	638	my %data = (
639	639	"red" => "boat",

711	711	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
712	712	ok $key eq "Wall" && $value eq "Brick" ;
713	713
714		#my $ref = $db->db_stat() ;
	714	#my $ref = $db->db_stat() ;
715	715	#ok ($ref->{bt_flags} \| DB_DUP) == DB_DUP ;
716	716	#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
717	717

728	728	my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
729	729	my %hash ;
730	730	my ($k, $v) ;
731		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	731	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
732	732	-Flags => DB_CREATE,
733	733	-Minkey =>3 ,
734		-Pagesize => 2 **12
	734	-Pagesize => 2 **12
735	735	;
736	736
737		my $ref = $db->db_stat() ;
	737	my $ref = $db->db_stat() ;
738	738	ok $ref->{$recs} == 0;
739	739	ok $ref->{'bt_minkey'} == 3;
740	740	ok $ref->{'bt_pagesize'} == 2 ** 12;

752	752	}
753	753	ok $ret == 0 ;
754	754
755		$ref = $db->db_stat() ;
	755	$ref = $db->db_stat() ;
756	756	ok $ref->{$recs} == 3;
757	757	}
758	758

776	776	@ISA=qw(BerkeleyDB BerkeleyDB::Btree );
777	777	@EXPORT = @BerkeleyDB::EXPORT ;
778	778
779		sub db_put {
	779	sub db_put {
780	780	my $self = shift ;
781	781	my $key = shift ;
782	782	my $value = shift ;
783	783	$self->SUPER::db_put($key, $value * 3) ;
784	784	}
785	785
786		sub db_get {
	786	sub db_get {
787	787	my $self = shift ;
788	788	$self->SUPER::db_get($_[0], $_[1]) ;
789	789	$_[1] -= 2 ;

803	803	close FILE ;
804	804
805	805	use Test::More;
806		BEGIN { push @INC, '.'; }
	806	BEGIN { push @INC, '.'; }
807	807	eval 'use SubDB ; ';
808	808	ok $@ eq "" ;
809	809	my %h ;
810	810	my $X ;
811	811	eval '
812		$X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
	812	$X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
813	813	-Flags => DB_CREATE,
814	814	-Mode => 0640 );
815	815	' ;

845	845	my $lex = new LexFile $Dfile ;
846	846	my %hash ;
847	847	my ($k, $v) = ("", "");
848		ok my $db = new BerkeleyDB::Btree
849		-Filename => $Dfile,
	848	ok my $db = new BerkeleyDB::Btree
	849	-Filename => $Dfile,
850	850	-Flags => DB_CREATE,
851	851	-Property => DB_RECNUM ;
852	852

919	919	ok $v == 4 ;
920	920
921	921	}
922

+4

-4

t/cds.t less more

4	4	use strict ;
5	5	use lib 't' ;
6	6
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

14	14	plan(skip_all => "this needs BerkeleyDB 2.x or better" )
15	15	if $BerkeleyDB::db_version < 2;
16	16
17		plan tests => 12;
	17	plan tests => 12;
18	18	}
19	19
20	20

34	34	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
35	35	-Home => $home, @StdErrFile ;
36	36
37		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	37	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
38	38	-Env => $env,
39	39	-Flags => DB_CREATE ;
40	40

57	57	ok my $env = new BerkeleyDB::Env -Flags => DB_INIT_CDB\|DB_CREATE\|DB_INIT_MPOOL,
58	58	-Home => $home, @StdErrFile ;
59	59
60		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	60	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
61	61	-Env => $env,
62	62	-Flags => DB_CREATE ;
63	63

+4

-5

t/db-3.0.t less more

4	4	use strict ;
5	5
6	6	use lib 't';
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9
10	10	use Test::More ;

13	13	plan(skip_all => "this needs BerkeleyDB 3.x or better" )
14	14	if $BerkeleyDB::db_version < 3;
15	15
16		plan tests => 14;
	16	plan tests => 14;
17	17	}
18	18
19	19	my $Dfile = "dbhash.tmp";

39	39	my $lex = new LexFile $Dfile ;
40	40	my %hash ;
41	41	my ($k, $v) ;
42		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	42	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
43	43	-Flags => DB_CREATE ;
44	44
45	45	# create some data

79	79	ok $dup_cursor->c_get($k, $v, DB_CURRENT) == 0;
80	80	ok $k eq "green" ;
81	81	ok $v eq "house" ;
82
	82
83	83	}
84

+25

-26

t/db-3.1.t less more

4	4	use lib 't';
5	5	use util ;
6	6
7		use Test::More ;
8
9		use BerkeleyDB;
10
11		plan(skip_all => "1..0 # Skip: this needs Berkeley DB 3.1.x or better\n")
	7	use Test::More ;
	8
	9	use BerkeleyDB;
	10
	11	plan(skip_all => "1..0 # Skip: this needs Berkeley DB 3.1.x or better\n")
12	12	if $BerkeleyDB::db_version < 3.1 ;
13	13
14	14	plan(tests => 48) ;

121	121	title "rename a subdb";
122	122
123	123	my $lex = new LexFile $Dfile ;
124
125		my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	124
	125	my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
126	126	-Subname => "fred" ,
127	127	-Flags => DB_CREATE ;
128	128	isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";
129	129
130		my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
	130	my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
131	131	-Subname => "joe" ,
132	132	-Flags => DB_CREATE ;
133	133	isa_ok $db2, 'BerkeleyDB::Btree', " create database ok";

147	147	undef $db1 ;
148	148	undef $db2 ;
149	149
150		# now rename
151		cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile,
	150	# now rename
	151	cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile,
152	152	-Subname => "fred",
153	153	-Newname => "harry"), '==', 0, " rename ok";
154
155		my $db3 = new BerkeleyDB::Hash -Filename => $Dfile,
	154
	155	my $db3 = new BerkeleyDB::Hash -Filename => $Dfile,
156	156	-Subname => "harry" ;
157	157	isa_ok $db3, 'BerkeleyDB::Hash', " verify rename";
158	158

162	162	title "rename a file";
163	163
164	164	my $lex = new LexFile $Dfile, $Dfile2 ;
165
166		my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	165
	166	my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
167	167	-Subname => "fred" ,
168	168	-Flags => DB_CREATE;
169	169	isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";
170	170
171		my $db2 = new BerkeleyDB::Hash -Filename => $Dfile,
	171	my $db2 = new BerkeleyDB::Hash -Filename => $Dfile,
172	172	-Subname => "joe" ,
173	173	-Flags => DB_CREATE ;
174	174	isa_ok $db2, 'BerkeleyDB::Hash', " create database ok";

188	188	undef $db1 ;
189	189	undef $db2 ;
190	190
191		# now rename
192		cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile, -Newname => $Dfile2),
	191	# now rename
	192	cmp_ok BerkeleyDB::db_rename(-Filename => $Dfile, -Newname => $Dfile2),
193	193	'==', 0, " rename file to $Dfile2 ok";
194
195		my $db3 = new BerkeleyDB::Hash -Filename => $Dfile2,
	194
	195	my $db3 = new BerkeleyDB::Hash -Filename => $Dfile2,
196	196	-Subname => "fred" ;
197	197	isa_ok $db3, 'BerkeleyDB::Hash', " verify rename"
198	198	or diag "$! $BerkeleyDB::Error";

205	205	title "verify";
206	206
207	207	my $lex = new LexFile $Dfile, $Dfile2 ;
208
209		my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	208
	209	my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
210	210	-Subname => "fred" ,
211	211	-Flags => DB_CREATE ;
212	212	isa_ok $db1, 'BerkeleyDB::Hash', " create database ok";

224	224
225	225	undef $db1 ;
226	226
227		# now verify
228		cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
	227	# now verify
	228	cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
229	229	-Subname => "fred",
230	230	), '==', 0, " verify ok";
231	231
232	232	# now verify & dump
233		cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
	233	cmp_ok BerkeleyDB::db_verify(-Filename => $Dfile,
234	234	-Subname => "fred",
235	235	-Outfile => $Dfile2,
236	236	), '==', 0, " verify and dump ok";
237
	237
238	238	}
239	239
240	240	# db_remove with env
241

+7

-7

t/db-3.2.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9
10	10	use Test::More ;

13	13	plan(skip_all => "this needs BerkeleyDB 3.2.x or better" )
14	14	if $BerkeleyDB::db_version < 3.2;
15	15
16		plan tests => 6;
	16	plan tests => 6;
17	17	}
18	18
19	19	my $Dfile = "dbhash.tmp";

39	39	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
40	40	-Flags => DB_CREATE ,
41	41	-SetFlags => DB_NOMMAP ;
42
43		undef $env ;
	42
	43	undef $env ;
44	44	}
45	45
46	46	{

51	51	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
52	52	-Flags => DB_CREATE ;
53	53	ok ! $env->set_flags(DB_NOMMAP, 1);
54
55		undef $env ;
	54
	55	undef $env ;
56	56	}

+18

-18

t/db-3.3.t less more

4	4
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

12	12	plan(skip_all => "this needs BerkeleyDB 3.3.x or better" )
13	13	if $BerkeleyDB::db_version < 3.3;
14	14
15		plan tests => 130;
	15	plan tests => 130;
16	16	}
17	17
18	18	umask(0);

24	24	my $lex = new LexFile $Dfile ;
25	25	my %hash ;
26	26	my ($k, $v) ;
27		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	27	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
28	28	-Flags => DB_CREATE ;
29	29
30	30	# create some data

72	72	my ($k, $v, $pk) = ('','','');
73	73
74	74	# create primary database
75		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	75	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
76	76	-Flags => DB_CREATE ;
77	77
78	78	# create secondary database
79		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	79	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
80	80	-Flags => DB_CREATE ;
81	81
82	82	# associate primary with secondary

120	120	ok my $p_cursor = $primary->db_cursor();
121	121	ok my $s_cursor = $secondary->db_cursor();
122	122
123		# c_get from primary
	123	# c_get from primary
124	124	$k = 'green';
125	125	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
126	126	is $k, 'green';

136	136	$k = 1;
137	137	ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
138	138
139		# c_pget from secondary database
	139	# c_pget from secondary database
140	140	$k = 'flag';
141	141	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
142	142	or diag "$BerkeleyDB::Error\n";

194	194	my ($k, $v, $pk) = ('','','');
195	195
196	196	# create primary database
197		ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
	197	ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
198	198	-Compare => sub { return $_[0] cmp $_[1]},
199	199	-Flags => DB_CREATE ;
200	200
201	201	# create secondary database
202		ok my $secondary = new BerkeleyDB::Btree -Filename => $Dfile2,
	202	ok my $secondary = new BerkeleyDB::Btree -Filename => $Dfile2,
203	203	-Compare => sub { return $_[0] <=> $_[1]},
204	204	-Property => DB_DUP,
205	205	-Flags => DB_CREATE ;

259	259	my ($k, $v, $pk) = ('','','');
260	260
261	261	# create primary database
262		ok my $primary = new BerkeleyDB::Recno -Filename => $Dfile1,
	262	ok my $primary = new BerkeleyDB::Recno -Filename => $Dfile1,
263	263	-Flags => DB_CREATE ;
264	264
265	265	# create secondary database
266		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	266	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
267	267	-Flags => DB_CREATE ;
268	268
269	269	# associate primary with secondary

307	307	ok my $p_cursor = $primary->db_cursor();
308	308	ok my $s_cursor = $secondary->db_cursor();
309	309
310		# c_get from primary
	310	# c_get from primary
311	311	$k = 1;
312	312	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
313	313	is $k, 1;

316	316	# c_get from secondary
317	317	$k = 'sea';
318	318	ok $s_cursor->c_get($k, $v, DB_SET) == 0;
319		is $k, 'sea'
	319	is $k, 'sea'
320	320	or warn "# key [$k]\n";
321	321	is $v, 'sea';
322	322

324	324	$k = 1;
325	325	ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
326	326
327		# c_pget from secondary database
	327	# c_pget from secondary database
328	328	$k = 'sea';
329	329	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
330	330	is $k, 'sea' ;

374	374	my ($k, $v, $pk) = ('','','');
375	375
376	376	# create primary database
377		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	377	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
378	378	-Flags => DB_CREATE ;
379	379
380	380	# create secondary database
381		ok my $secondary = new BerkeleyDB::Recno -Filename => $Dfile2,
	381	ok my $secondary = new BerkeleyDB::Recno -Filename => $Dfile2,
382	382	#-Property => DB_DUP,
383	383	-Flags => DB_CREATE ;
384	384

427	427	ok my $p_cursor = $primary->db_cursor();
428	428	ok my $s_cursor = $secondary->db_cursor();
429	429
430		# c_get from primary
	430	# c_get from primary
431	431	$k = 'green';
432	432	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
433	433	is $k, 'green';

443	443	$k = 1;
444	444	ok $p_cursor->c_pget($k, $pk, $v, DB_SET) != 0;
445	445
446		# c_pget from secondary database
	446	# c_pget from secondary database
447	447	$k = 5;
448	448	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
449	449	or diag "$BerkeleyDB::Error\n";

+6

-6

t/db-4.3.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use Test::More ;
7	7	use util ;
8	8

19	19	my $home = "./fred" ;
20	20	ok my $lexD = new LexDir($home) ;
21	21	my $lex = new LexFile $msgfile ;
22		ok my $env = new BerkeleyDB::Env( -MsgFile => $msgfile,
	22	ok my $env = new BerkeleyDB::Env( -MsgFile => $msgfile,
23	23	-Flags => DB_CREATE,
24	24	-Home => $home) ;
25	25	$env->stat_print();

37	37	ok my $lexD = new LexDir($home) ;
38	38	my $lex = new LexFile $msgfile ;
39	39	my $fh = new IO::File ">$msgfile" ;
40		ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
	40	ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
41	41	-Flags => DB_CREATE,
42	42	-Home => $home) ;
43	43	is $env->stat_print(), 0;

57	57	my $Dfile = "db.db";
58	58	my $lex1 = new LexFile $Dfile ;
59	59	my $fh = new IO::File ">$msgfile" ;
60		ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
	60	ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
61	61	-Flags => DB_CREATE\|DB_INIT_MPOOL,
62	62	-Home => $home) ;
63		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	63	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
64	64	-Env => $env,
65	65	-Flags => DB_CREATE ;
66	66	is $db->stat_print(), 0;

79	79	ok my $lexD = new LexDir($home) ;
80	80	my $lex = new LexFile $msgfile ;
81	81	my $fh = new IO::File ">$msgfile" ;
82		ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
	82	ok my $env = new BerkeleyDB::Env( -MsgFile => $fh,
83	83	-Flags => DB_CREATE\|DB_INIT_TXN,
84	84	-Home => $home) ;
85	85	is $env->txn_stat_print(), 0

+3

-3

t/db-4.4.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use Test::More ;
7	7	use util ;
8	8

19	19	my $Dfile;
20	20	my $lex = new LexFile $Dfile ;
21	21	my ($k, $v) ;
22		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	22	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
23	23	-Flags => DB_CREATE ;
24	24
25	25	# create some data

73	73	ok $env ;
74	74
75	75	# something crazy small
76		#is($env->set_lg_max(1024), 0);
	76	#is($env->set_lg_max(1024), 0);
77	77
78	78	ok my $txn = $env->txn_begin() ;
79	79

+7

-8

t/db-4.6.t less more

4	4
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9
10	10	use Test::More ;

13	13	plan(skip_all => "this needs BerkeleyDB 4.6.x or better" )
14	14	if $BerkeleyDB::db_version < 4.6;
15	15
16		plan tests => 69;
	16	plan tests => 69;
17	17	}
18	18
19	19	umask(0);

38	38	my ($k, $v, $pk) = ('','','');
39	39
40	40	# create primary database
41		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	41	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
42	42	-Flags => DB_CREATE ;
43	43
44	44	# create secondary database
45		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	45	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
46	46	-Flags => DB_CREATE ;
47	47
48	48	# associate primary with secondary

85	85	my ($k, $v, $pk) = ('','','');
86	86
87	87	# create primary database
88		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	88	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
89	89	-Flags => DB_CREATE ;
90	90
91	91	# create secondary database
92		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	92	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
93	93	-Flags => DB_CREATE ;
94	94
95	95	# associate primary with secondary

183	183	ok $pk eq 'bar';
184	184	ok $v eq 'hello,goodbye';
185	185
186		# pget to DB_GET_BOTH from secondary database
	186	# pget to DB_GET_BOTH from secondary database
187	187	$k = 'house';
188	188	$pk = 'green';
189	189	ok $secondary->db_pget($k, $pk, $v, DB_GET_BOTH) == 0 ;

244	244	ok $primary->db_get("red", $v) != 0;
245	245	is countRecords($primary), 3 ;
246	246	}
247

+1

-1

t/db-4.7.t less more

4	4
5	5	use lib 't' ;
6	6
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9
10	10	use Test::More ;

+20

-20

t/db-4.8.t less more

4	4
5	5	use lib 't' ;
6	6
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9
10	10	use Test::More ;

38	38	my ($k, $v, $pk) = ('','','');
39	39
40	40	# create primary database
41		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
42		-Flags => DB_CREATE ;
43
44		# create secondary database
45		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	41	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	42	-Flags => DB_CREATE ;
	43
	44	# create secondary database
	45	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
46	46	-Flags => DB_CREATE ;
47	47
48	48	# associate primary with secondary
49	49	ok $primary->associate($secondary, \&sec_key) == 0;
50	50
51	51	# create secondary database
52		ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
	52	ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
53	53	-Flags => DB_CREATE ;
54	54
55	55	# associate primary with secondary

124	124	my ($k, $v, $pk) = ('','','');
125	125
126	126	# create primary database
127		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
128		-Flags => DB_CREATE ;
129
130		# create secondary database
131		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	127	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	128	-Flags => DB_CREATE ;
	129
	130	# create secondary database
	131	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
132	132	-Flags => DB_CREATE ;
133	133
134	134	# associate primary with secondary
135	135	ok $primary->associate($secondary, \&sec_key2) == 0;
136	136
137	137	# create secondary database
138		ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
	138	ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
139	139	-Flags => DB_CREATE ;
140	140
141	141	# associate primary with secondary

225	225	my ($k, $v, $pk) = ('','','');
226	226
227	227	# create primary database
228		ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
229		-Flags => DB_CREATE ;
230
231		# create secondary database
232		ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	228	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	229	-Flags => DB_CREATE ;
	230
	231	# create secondary database
	232	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
233	233	-Flags => DB_CREATE ;
234	234
235	235	# associate primary with secondary
236	236	ok $primary->associate($secondary, \&sec_key3) == 0;
237	237
238	238	# create secondary database
239		ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
	239	ok my $foreign = new BerkeleyDB::Hash -Filename => $Dfile3,
240	240	-Flags => DB_CREATE ;
241	241
242	242	# associate primary with secondary

299	299	my ($k, $v, $pk) = ('','','');
300	300
301	301	# create primary database
302		ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
	302	ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
303	303	-set_bt_compress => 1,
304	304	-Flags => DB_CREATE ;
305	305

+1

-1

t/db-4.x.t less more

1	1
2	2	use strict ;
3	3	use lib 't';
4		use BerkeleyDB;
	4	use BerkeleyDB;
5	5	use Test::More;
6	6	use util ;
7	7

+3

-5

t/destroy.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7	use Test::More;
8	8

33	33	ok $txn->txn_commit() == 0 ;
34	34	ok $txn = $env->txn_begin() ;
35	35	$db1->Txn($txn);
36
	36
37	37	# create some data
38	38	my %data = (
39	39	"red" => "boat",

84	84	my %hash ;
85	85	my $cursor ;
86	86	my ($k, $v) = ("", "") ;
87		ok my $db1 = tie %hash, 'BerkeleyDB::Hash',
	87	ok my $db1 = tie %hash, 'BerkeleyDB::Hash',
88	88	-Filename => $Dfile,
89	89	-Flags => DB_CREATE ;
90	90	my $count = 0 ;

95	95	}
96	96	is $count, 0 ;
97	97	}
98
99

+9

-9

t/encode.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7	use Test::More ;
8	8
9		BEGIN
	9	BEGIN
10	10	{
11	11	eval { require Encode; };
12
	12
13	13	plan skip_all => "Encode is not available"
14	14	if $@;
15	15

36	36	my (%h, $db) ;
37	37	unlink $Dfile;
38	38
39		ok $db = tie %h, 'BerkeleyDB::Hash',
40		-Filename => $Dfile,
41		-Flags => DB_CREATE;
	39	ok $db = tie %h, 'BerkeleyDB::Hash',
	40	-Filename => $Dfile,
	41	-Flags => DB_CREATE;
42	42
43	43	$db->filter_fetch_key (sub { $_ = Encode::decode_utf8($_) if defined $_ });
44	44	$db->filter_store_key (sub { $_ = Encode::encode_utf8($_) if defined $_ });

55	55	untie %h;
56	56
57	57	my %newH;
58		ok $db = tie %newH, 'BerkeleyDB::Hash',
59		-Filename => $Dfile,
60		-Flags => DB_CREATE;
	58	ok $db = tie %newH, 'BerkeleyDB::Hash',
	59	-Filename => $Dfile,
	60	-Flags => DB_CREATE;
61	61
62	62	$newH{"fred"} = "joe" ;
63	63	is $newH{"fred"}, "joe";

+95

-96

t/encrypt.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

27	27
28	28	umask(0);
29	29
30		{
	30	{
31	31	eval
32	32	{
33	33	my $env = new BerkeleyDB::Env @StdErrFile,

90	90	my $lex = new LexFile $Dfile ;
91	91	my %hash ;
92	92	my ($k, $v) ;
93		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	93	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
94	94	-Env => $env,
95		-Flags => DB_CREATE,
	95	-Flags => DB_CREATE,
96	96	-Property => DB_ENCRYPT ;
97	97
98	98	# create some data

114	114	undef $db;
115	115
116	116	# once the database is created, do not need to specify DB_ENCRYPT
117		ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	117	ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
118	118	-Env => $env,
119	119	-Flags => DB_CREATE ;
120		$v = '';
	120	$v = '';
121	121	ok ! $db1->db_get("red", $v) ;
122	122	ok $v eq $data{"red"},
123	123	undef $db1;
124	124	undef $env;
125	125
126	126	# open a database without specifying encryption
127		ok ! new BerkeleyDB::Hash -Filename => "$home/$Dfile";
128
129		ok ! new BerkeleyDB::Env
	127	ok ! new BerkeleyDB::Hash -Filename => "$home/$Dfile";
	128
	129	ok ! new BerkeleyDB::Env
130	130	-Home => $home,
131	131	-Encrypt => {Password => "def",
132	132	Flags => DB_ENCRYPT_AES

134	134	-Flags => DB_CREATE \| DB_INIT_MPOOL ;
135	135	}
136	136
137		{
138		eval
139		{
140		my $env = new BerkeleyDB::Hash
	137	{
	138	eval
	139	{
	140	my $env = new BerkeleyDB::Hash
141	141	-Encrypt => 1,
142	142	-Flags => DB_CREATE ;
143	143	};

145	145
146	146	eval
147	147	{
148		my $env = new BerkeleyDB::Hash
	148	my $env = new BerkeleyDB::Hash
149	149	-Encrypt => {},
150	150	-Flags => DB_CREATE ;
151	151	};

153	153
154	154	eval
155	155	{
156		my $env = new BerkeleyDB::Hash
	156	my $env = new BerkeleyDB::Hash
157	157	-Encrypt => {Password => "fred"},
158	158	-Flags => DB_CREATE ;
159	159	};

161	161
162	162	eval
163	163	{
164		my $env = new BerkeleyDB::Hash
	164	my $env = new BerkeleyDB::Hash
165	165	-Encrypt => {Flags => 1},
166	166	-Flags => DB_CREATE ;
167	167	};

169	169
170	170	eval
171	171	{
172		my $env = new BerkeleyDB::Hash
	172	my $env = new BerkeleyDB::Hash
173	173	-Encrypt => {Fred => 1},
174	174	-Flags => DB_CREATE ;
175	175	};

177	177
178	178	}
179	179
180		{
181		eval
182		{
183		my $env = new BerkeleyDB::Btree
	180	{
	181	eval
	182	{
	183	my $env = new BerkeleyDB::Btree
184	184	-Encrypt => 1,
185	185	-Flags => DB_CREATE ;
186	186	};

188	188
189	189	eval
190	190	{
191		my $env = new BerkeleyDB::Btree
	191	my $env = new BerkeleyDB::Btree
192	192	-Encrypt => {},
193	193	-Flags => DB_CREATE ;
194	194	};

196	196
197	197	eval
198	198	{
199		my $env = new BerkeleyDB::Btree
	199	my $env = new BerkeleyDB::Btree
200	200	-Encrypt => {Password => "fred"},
201	201	-Flags => DB_CREATE ;
202	202	};

204	204
205	205	eval
206	206	{
207		my $env = new BerkeleyDB::Btree
	207	my $env = new BerkeleyDB::Btree
208	208	-Encrypt => {Flags => 1},
209	209	-Flags => DB_CREATE ;
210	210	};

212	212
213	213	eval
214	214	{
215		my $env = new BerkeleyDB::Btree
	215	my $env = new BerkeleyDB::Btree
216	216	-Encrypt => {Fred => 1},
217	217	-Flags => DB_CREATE ;
218	218	};

220	220
221	221	}
222	222
223		{
224		eval
225		{
226		my $env = new BerkeleyDB::Queue
	223	{
	224	eval
	225	{
	226	my $env = new BerkeleyDB::Queue
227	227	-Encrypt => 1,
228	228	-Flags => DB_CREATE ;
229	229	};

231	231
232	232	eval
233	233	{
234		my $env = new BerkeleyDB::Queue
	234	my $env = new BerkeleyDB::Queue
235	235	-Encrypt => {},
236	236	-Flags => DB_CREATE ;
237	237	};

239	239
240	240	eval
241	241	{
242		my $env = new BerkeleyDB::Queue
	242	my $env = new BerkeleyDB::Queue
243	243	-Encrypt => {Password => "fred"},
244	244	-Flags => DB_CREATE ;
245	245	};

247	247
248	248	eval
249	249	{
250		my $env = new BerkeleyDB::Queue
	250	my $env = new BerkeleyDB::Queue
251	251	-Encrypt => {Flags => 1},
252	252	-Flags => DB_CREATE ;
253	253	};

255	255
256	256	eval
257	257	{
258		my $env = new BerkeleyDB::Queue
	258	my $env = new BerkeleyDB::Queue
259	259	-Encrypt => {Fred => 1},
260	260	-Flags => DB_CREATE ;
261	261	};

263	263
264	264	}
265	265
266		{
267		eval
268		{
269		my $env = new BerkeleyDB::Recno
	266	{
	267	eval
	268	{
	269	my $env = new BerkeleyDB::Recno
270	270	-Encrypt => 1,
271	271	-Flags => DB_CREATE ;
272	272	};

274	274
275	275	eval
276	276	{
277		my $env = new BerkeleyDB::Recno
	277	my $env = new BerkeleyDB::Recno
278	278	-Encrypt => {},
279	279	-Flags => DB_CREATE ;
280	280	};

282	282
283	283	eval
284	284	{
285		my $env = new BerkeleyDB::Recno
	285	my $env = new BerkeleyDB::Recno
286	286	-Encrypt => {Password => "fred"},
287	287	-Flags => DB_CREATE ;
288	288	};

290	290
291	291	eval
292	292	{
293		my $env = new BerkeleyDB::Recno
	293	my $env = new BerkeleyDB::Recno
294	294	-Encrypt => {Flags => 1},
295	295	-Flags => DB_CREATE ;
296	296	};

298	298
299	299	eval
300	300	{
301		my $env = new BerkeleyDB::Recno
	301	my $env = new BerkeleyDB::Recno
302	302	-Encrypt => {Fred => 1},
303	303	-Flags => DB_CREATE ;
304	304	};

314	314	my $lex = new LexFile $Dfile ;
315	315	my %hash ;
316	316	my ($k, $v) ;
317		ok my $db = new BerkeleyDB::Hash
318		-Filename => $Dfile,
319		-Flags => DB_CREATE,
	317	ok my $db = new BerkeleyDB::Hash
	318	-Filename => $Dfile,
	319	-Flags => DB_CREATE,
320	320	-Encrypt => {Password => "beta",
321	321	Flags => DB_ENCRYPT_AES
322	322	},

341	341	undef $db;
342	342
343	343	# attempt to open a database without specifying encryption
344		ok ! new BerkeleyDB::Hash -Filename => $Dfile,
	344	ok ! new BerkeleyDB::Hash -Filename => $Dfile,
345	345	-Flags => DB_CREATE ;
346	346
347	347
348		# try opening with the wrong password
349		ok ! new BerkeleyDB::Hash -Filename => $Dfile,
350		-Filename => $Dfile,
	348	# try opening with the wrong password
	349	ok ! new BerkeleyDB::Hash -Filename => $Dfile,
	350	-Filename => $Dfile,
351	351	-Encrypt => {Password => "def",
352	352	Flags => DB_ENCRYPT_AES
353	353	},
354	354	-Property => DB_ENCRYPT ;
355	355
356	356
357		# read the encrypted data
358		ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
359		-Filename => $Dfile,
	357	# read the encrypted data
	358	ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	359	-Filename => $Dfile,
360	360	-Encrypt => {Password => "beta",
361	361	Flags => DB_ENCRYPT_AES
362	362	},
363	363	-Property => DB_ENCRYPT ;
364	364
365	365
366		$v = '';
	366	$v = '';
367	367	ok ! $db1->db_get("red", $v) ;
368	368	ok $v eq $data{"red"};
369	369	# check there are three records

378	378	my $lex = new LexFile $Dfile ;
379	379	my %hash ;
380	380	my ($k, $v) ;
381		ok my $db = new BerkeleyDB::Btree
382		-Filename => $Dfile,
383		-Flags => DB_CREATE,
	381	ok my $db = new BerkeleyDB::Btree
	382	-Filename => $Dfile,
	383	-Flags => DB_CREATE,
384	384	-Encrypt => {Password => "beta",
385	385	Flags => DB_ENCRYPT_AES
386	386	},

405	405	undef $db;
406	406
407	407	# attempt to open a database without specifying encryption
408		ok ! new BerkeleyDB::Btree -Filename => $Dfile,
	408	ok ! new BerkeleyDB::Btree -Filename => $Dfile,
409	409	-Flags => DB_CREATE ;
410	410
411	411
412		# try opening with the wrong password
413		ok ! new BerkeleyDB::Btree -Filename => $Dfile,
414		-Filename => $Dfile,
	412	# try opening with the wrong password
	413	ok ! new BerkeleyDB::Btree -Filename => $Dfile,
	414	-Filename => $Dfile,
415	415	-Encrypt => {Password => "def",
416	416	Flags => DB_ENCRYPT_AES
417	417	},
418	418	-Property => DB_ENCRYPT ;
419	419
420	420
421		# read the encrypted data
422		ok my $db1 = new BerkeleyDB::Btree -Filename => $Dfile,
423		-Filename => $Dfile,
	421	# read the encrypted data
	422	ok my $db1 = new BerkeleyDB::Btree -Filename => $Dfile,
	423	-Filename => $Dfile,
424	424	-Encrypt => {Password => "beta",
425	425	Flags => DB_ENCRYPT_AES
426	426	},
427	427	-Property => DB_ENCRYPT ;
428	428
429	429
430		$v = '';
	430	$v = '';
431	431	ok ! $db1->db_get("red", $v) ;
432	432	ok $v eq $data{"red"};
433	433	# check there are three records

442	442	my $lex = new LexFile $Dfile ;
443	443	my %hash ;
444	444	my ($k, $v) ;
445		ok my $db = new BerkeleyDB::Queue
446		-Filename => $Dfile,
	445	ok my $db = new BerkeleyDB::Queue
	446	-Filename => $Dfile,
447	447	-Len => 5,
448	448	-Pad => "x",
449		-Flags => DB_CREATE,
	449	-Flags => DB_CREATE,
450	450	-Encrypt => {Password => "beta",
451	451	Flags => DB_ENCRYPT_AES
452	452	},

471	471	undef $db;
472	472
473	473	# attempt to open a database without specifying encryption
474		ok ! new BerkeleyDB::Queue -Filename => $Dfile,
	474	ok ! new BerkeleyDB::Queue -Filename => $Dfile,
475	475	-Len => 5,
476	476	-Pad => "x",
477	477	-Flags => DB_CREATE ;
478	478
479	479
480		# try opening with the wrong password
481		ok ! new BerkeleyDB::Queue -Filename => $Dfile,
	480	# try opening with the wrong password
	481	ok ! new BerkeleyDB::Queue -Filename => $Dfile,
482	482	-Len => 5,
483	483	-Pad => "x",
484	484	-Encrypt => {Password => "def",

487	487	-Property => DB_ENCRYPT ;
488	488
489	489
490		# read the encrypted data
491		ok my $db1 = new BerkeleyDB::Queue -Filename => $Dfile,
	490	# read the encrypted data
	491	ok my $db1 = new BerkeleyDB::Queue -Filename => $Dfile,
492	492	-Len => 5,
493	493	-Pad => "x",
494	494	-Encrypt => {Password => "beta",

497	497	-Property => DB_ENCRYPT ;
498	498
499	499
500		$v = '';
	500	$v = '';
501	501	ok ! $db1->db_get(3, $v) ;
502	502	ok $v eq fillout($data{3}, 5, 'x');
503	503	# check there are three records

512	512	my $lex = new LexFile $Dfile ;
513	513	my %hash ;
514	514	my ($k, $v) ;
515		ok my $db = new BerkeleyDB::Recno
516		-Filename => $Dfile,
517		-Flags => DB_CREATE,
	515	ok my $db = new BerkeleyDB::Recno
	516	-Filename => $Dfile,
	517	-Flags => DB_CREATE,
518	518	-Encrypt => {Password => "beta",
519	519	Flags => DB_ENCRYPT_AES
520	520	},

539	539	undef $db;
540	540
541	541	# attempt to open a database without specifying encryption
542		ok ! new BerkeleyDB::Recno -Filename => $Dfile,
	542	ok ! new BerkeleyDB::Recno -Filename => $Dfile,
543	543	-Flags => DB_CREATE ;
544	544
545	545
546		# try opening with the wrong password
547		ok ! new BerkeleyDB::Recno -Filename => $Dfile,
548		-Filename => $Dfile,
	546	# try opening with the wrong password
	547	ok ! new BerkeleyDB::Recno -Filename => $Dfile,
	548	-Filename => $Dfile,
549	549	-Encrypt => {Password => "def",
550	550	Flags => DB_ENCRYPT_AES
551	551	},
552	552	-Property => DB_ENCRYPT ;
553	553
554	554
555		# read the encrypted data
556		ok my $db1 = new BerkeleyDB::Recno -Filename => $Dfile,
557		-Filename => $Dfile,
	555	# read the encrypted data
	556	ok my $db1 = new BerkeleyDB::Recno -Filename => $Dfile,
	557	-Filename => $Dfile,
558	558	-Encrypt => {Password => "beta",
559	559	Flags => DB_ENCRYPT_AES
560	560	},
561	561	-Property => DB_ENCRYPT ;
562	562
563	563
564		$v = '';
	564	$v = '';
565	565	ok ! $db1->db_get(3, $v) ;
566	566	ok $v eq $data{3};
567	567	# check there are three records

576	576	my $lex = new LexFile $Dfile ;
577	577	my %hash ;
578	578	my ($k, $v) ;
579		ok my $db = new BerkeleyDB::Hash
580		-Filename => $Dfile,
581		-Flags => DB_CREATE,
	579	ok my $db = new BerkeleyDB::Hash
	580	-Filename => $Dfile,
	581	-Flags => DB_CREATE,
582	582	-Encrypt => {Password => "beta",
583	583	Flags => DB_ENCRYPT_AES
584	584	},

603	603	undef $db;
604	604
605	605	# attempt to open a database without specifying encryption
606		ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
	606	ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
607	607	-Flags => DB_CREATE ;
608	608
609	609
610		# try opening with the wrong password
611		ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
612		-Filename => $Dfile,
	610	# try opening with the wrong password
	611	ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
	612	-Filename => $Dfile,
613	613	-Encrypt => {Password => "def",
614	614	Flags => DB_ENCRYPT_AES
615	615	},
616	616	-Property => DB_ENCRYPT ;
617	617
618	618
619		# read the encrypted data
620		ok my $db1 = new BerkeleyDB::Unknown -Filename => $Dfile,
621		-Filename => $Dfile,
	619	# read the encrypted data
	620	ok my $db1 = new BerkeleyDB::Unknown -Filename => $Dfile,
	621	-Filename => $Dfile,
622	622	-Encrypt => {Password => "beta",
623	623	Flags => DB_ENCRYPT_AES
624	624	},
625	625	-Property => DB_ENCRYPT ;
626	626
627	627
628		$v = '';
	628	$v = '';
629	629	ok ! $db1->db_get("red", $v) ;
630	630	ok $v eq $data{"red"};
631	631	# check there are three records
632	632	ok countRecords($db1) == 3 ;
633	633	undef $db1;
634	634	}
635

+6

-6

t/env.t less more

8	8	$ENV{LC_ALL} = 'de_DE@euro';
9	9	}
10	10
11		use BerkeleyDB;
	11	use BerkeleyDB;
12	12	use util ;
13	13
14	14	use Test::More ;

129	129	my $ErrMsg = join "\|", map { "$prefix$_" }
130	130	'illegal flag specified to (db_open\|DB->open)',
131	131	'(BDB\d+ )?DB_AUTO_COMMIT may not be specified in non-transactional environment';
132
	132
133	133	return 1 if $BerkeleyDB::Error =~ /^$ErrMsg/ ;
134	134	warn "# $BerkeleyDB::Error\n" ;
135	135	return 0;

141	141	my $home = "./fred" ;
142	142	ok my $lexD = new LexDir($home), "lexdir" ;
143	143	my $lex = new LexFile $errfile ;
144		ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
	144	ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
145	145	-Flags => DB_CREATE,
146	146	-Home => $home) ;
147	147	my $db = new BerkeleyDB::Hash -Filename => $Dfile,

151	151
152	152	my $ErrMsg = join "'", 'illegal flag specified to (db_open\|DB->open)',
153	153	'DB_AUTO_COMMIT may not be specified in non-transactional environment';
154
	154
155	155	ok chkMsg();
156	156	ok -e $errfile ;
157	157	my $contents = docat($errfile) ;

169	169	ok my $lexD = new LexDir($home) ;
170	170	my $lex = new LexFile $errfile ;
171	171	my $fh = new IO::File ">$errfile" ;
172		ok my $env = new BerkeleyDB::Env( -ErrFile => $fh,
	172	ok my $env = new BerkeleyDB::Env( -ErrFile => $fh,
173	173	-Flags => DB_CREATE,
174	174	-Home => $home) ;
175	175	my $db = new BerkeleyDB::Hash -Filename => $Dfile,

260	260	# The test below is not portable -- the error message returned by
261	261	# $BerkeleyDB::Error is locale dependant.
262	262
263		#ok $version_major == 2 ? 1
	263	#ok $version_major == 2 ? 1
264	264	# : $BerkeleyDB::Error =~ /No such file or directory/ ;
265	265	# or print "# BerkeleyDB::Error is $BerkeleyDB::Error\n";
266	266	chdir ".." ;

+32

-33

t/examples.t less more

0	0	#!./perl -w
1	1
2		use strict ;
	2	use strict ;
3	3
4	4	BEGIN {
5	5	unless(grep /blib/, @INC) {

9	9	}
10	10
11	11	use lib 't';
12		use BerkeleyDB;
	12	use BerkeleyDB;
13	13	use Test::More;
14	14	use util;
15	15

34	34	use strict ;
35	35	use BerkeleyDB ;
36	36	use vars qw( %h $k $v ) ;
37
	37
38	38	my $filename = "fruit" ;
39	39	unlink $filename ;
40		tie %h, "BerkeleyDB::Hash",
41		-Filename => $filename,
	40	tie %h, "BerkeleyDB::Hash",
	41	-Filename => $filename,
42	42	-Flags => DB_CREATE
43	43	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
44	44

47	47	$h{"orange"} = "orange" ;
48	48	$h{"banana"} = "yellow" ;
49	49	$h{"tomato"} = "red" ;
50
	50
51	51	# Check for existence of a key
52	52	print "Banana Exists\n\n" if $h{"banana"} ;
53
	53
54	54	# Delete a key/value pair.
55	55	delete $h{"apple"} ;
56
	56
57	57	# print the contents of the file
58	58	while (($k, $v) = each %h)
59	59	{ print "$k -> $v\n" }
60
	60
61	61	untie %h ;
62	62	unlink $filename ;
63	63	}

82	82
83	83	use strict ;
84	84	use BerkeleyDB ;
85
	85
86	86	my $filename = "fruit" ;
87	87	unlink $filename ;
88		my $db = new BerkeleyDB::Hash
89		-Filename => $filename,
	88	my $db = new BerkeleyDB::Hash
	89	-Filename => $filename,
90	90	-Flags => DB_CREATE
91	91	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
92	92

95	95	$db->db_put("orange", "orange") ;
96	96	$db->db_put("banana", "yellow") ;
97	97	$db->db_put("tomato", "red") ;
98
	98
99	99	# Check for existence of a key
100	100	print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
101
	101
102	102	# Delete a key/value pair.
103	103	$db->db_del("apple") ;
104
	104
105	105	# print the contents of the file
106	106	my ($k, $v) = ("", "") ;
107	107	my $cursor = $db->db_cursor() ;
108	108	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
109	109	{ print "$k -> $v\n" }
110
	110
111	111	undef $cursor ;
112	112	undef $db ;
113	113	unlink $filename ;

136	136	my $filename = "tree" ;
137	137	unlink $filename ;
138	138	my %h ;
139		tie %h, 'BerkeleyDB::Btree',
140		-Filename => $filename,
	139	tie %h, 'BerkeleyDB::Btree',
	140	-Filename => $filename,
141	141	-Flags => DB_CREATE
142	142	or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
143	143

181	181	my $filename = "tree" ;
182	182	unlink $filename ;
183	183	my %h ;
184		tie %h, 'BerkeleyDB::Btree',
185		-Filename => $filename,
	184	tie %h, 'BerkeleyDB::Btree',
	185	-Filename => $filename,
186	186	-Flags => DB_CREATE,
187	187	-Compare => sub { lc $_[0] cmp lc $_[1] }
188	188	or die "Cannot open $filename: $!\n" ;

228	228	my $filename = "filt.db" ;
229	229	unlink $filename ;
230	230
231		my $db = tie %hash, 'BerkeleyDB::Hash',
232		-Filename => $filename,
	231	my $db = tie %hash, 'BerkeleyDB::Hash',
	232	-Filename => $filename,
233	233	-Flags => DB_CREATE
234	234	or die "Cannot open $filename: $!\n" ;
235	235

244	244	# ...
245	245	undef $db ;
246	246	untie %hash ;
247		$db = tie %hash, 'BerkeleyDB::Hash',
248		-Filename => $filename,
	247	$db = tie %hash, 'BerkeleyDB::Hash',
	248	-Filename => $filename,
249	249	-Flags => DB_CREATE
250	250	or die "Cannot open $filename: $!\n" ;
251	251	while (($k, $v) = each %hash)

276	276	unlink $filename ;
277	277
278	278
279		my $db = tie %hash, 'BerkeleyDB::Btree',
280		-Filename => $filename,
	279	my $db = tie %hash, 'BerkeleyDB::Btree',
	280	-Filename => $filename,
281	281	-Flags => DB_CREATE
282	282	or die "Cannot open $filename: $!\n" ;
283	283

287	287	# ...
288	288	undef $db ;
289	289	untie %hash ;
290		$db = tie %hash, 'BerkeleyDB::Btree',
291		-Filename => $filename,
	290	$db = tie %hash, 'BerkeleyDB::Btree',
	291	-Filename => $filename,
292	292	-Flags => DB_CREATE
293	293	or die "Cannot Open $filename: $!\n" ;
294	294	while (($k, $v) = each %hash)

321	321	unlink $filename ;
322	322
323	323	my @h ;
324		tie @h, 'BerkeleyDB::Recno',
325		-Filename => $filename,
	324	tie @h, 'BerkeleyDB::Recno',
	325	-Filename => $filename,
326	326	-Flags => DB_CREATE,
327	327	-Property => DB_RENUMBER
328	328	or die "Cannot open $filename: $!\n" ;

357	357	unlink $filename ;
358	358
359	359	my @h ;
360		my $db = tie @h, 'BerkeleyDB::Recno',
361		-Filename => $filename,
	360	my $db = tie @h, 'BerkeleyDB::Recno',
	361	-Filename => $filename,
362	362	-Flags => DB_CREATE,
363	363	-Property => DB_RENUMBER
364	364	or die "Cannot open $filename: $!\n" ;

399	399	EOM
400	400
401	401	}
402

+32

-33

t/examples.t.T less more

0	0	#!./perl -w
1	1
2		use strict ;
	2	use strict ;
3	3
4	4	BEGIN {
5	5	unless(grep /blib/, @INC) {

9	9	}
10	10
11	11	use lib 't';
12		use BerkeleyDB;
	12	use BerkeleyDB;
13	13	use Test::More;
14	14	use util;
15	15

35	35	use strict ;
36	36	use BerkeleyDB ;
37	37	use vars qw( %h $k $v ) ;
38
	38
39	39	my $filename = "fruit" ;
40	40	unlink $filename ;
41		tie %h, "BerkeleyDB::Hash",
42		-Filename => $filename,
	41	tie %h, "BerkeleyDB::Hash",
	42	-Filename => $filename,
43	43	-Flags => DB_CREATE
44	44	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
45	45

48	48	$h{"orange"} = "orange" ;
49	49	$h{"banana"} = "yellow" ;
50	50	$h{"tomato"} = "red" ;
51
	51
52	52	# Check for existence of a key
53	53	print "Banana Exists\n\n" if $h{"banana"} ;
54
	54
55	55	# Delete a key/value pair.
56	56	delete $h{"apple"} ;
57
	57
58	58	# print the contents of the file
59	59	while (($k, $v) = each %h)
60	60	{ print "$k -> $v\n" }
61
	61
62	62	untie %h ;
63	63	## END simpleHash
64	64	unlink $filename ;

85	85	## BEGIN simpleHash2
86	86	use strict ;
87	87	use BerkeleyDB ;
88
	88
89	89	my $filename = "fruit" ;
90	90	unlink $filename ;
91		my $db = new BerkeleyDB::Hash
92		-Filename => $filename,
	91	my $db = new BerkeleyDB::Hash
	92	-Filename => $filename,
93	93	-Flags => DB_CREATE
94	94	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;
95	95

98	98	$db->db_put("orange", "orange") ;
99	99	$db->db_put("banana", "yellow") ;
100	100	$db->db_put("tomato", "red") ;
101
	101
102	102	# Check for existence of a key
103	103	print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
104
	104
105	105	# Delete a key/value pair.
106	106	$db->db_del("apple") ;
107
	107
108	108	# print the contents of the file
109	109	my ($k, $v) = ("", "") ;
110	110	my $cursor = $db->db_cursor() ;
111	111	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
112	112	{ print "$k -> $v\n" }
113
	113
114	114	undef $cursor ;
115	115	undef $db ;
116	116	## END simpleHash2

141	141	my $filename = "tree" ;
142	142	unlink $filename ;
143	143	my %h ;
144		tie %h, 'BerkeleyDB::Btree',
145		-Filename => $filename,
	144	tie %h, 'BerkeleyDB::Btree',
	145	-Filename => $filename,
146	146	-Flags => DB_CREATE
147	147	or die "Cannot open $filename: $! $BerkeleyDB::Error\n" ;
148	148

188	188	my $filename = "tree" ;
189	189	unlink $filename ;
190	190	my %h ;
191		tie %h, 'BerkeleyDB::Btree',
192		-Filename => $filename,
	191	tie %h, 'BerkeleyDB::Btree',
	192	-Filename => $filename,
193	193	-Flags => DB_CREATE,
194	194	-Compare => sub { lc $_[0] cmp lc $_[1] }
195	195	or die "Cannot open $filename: $!\n" ;

237	237	my $filename = "filt.db" ;
238	238	unlink $filename ;
239	239
240		my $db = tie %hash, 'BerkeleyDB::Hash',
241		-Filename => $filename,
	240	my $db = tie %hash, 'BerkeleyDB::Hash',
	241	-Filename => $filename,
242	242	-Flags => DB_CREATE
243	243	or die "Cannot open $filename: $!\n" ;
244	244

254	254	undef $db ;
255	255	untie %hash ;
256	256	## END nullFilter
257		$db = tie %hash, 'BerkeleyDB::Hash',
258		-Filename => $filename,
	257	$db = tie %hash, 'BerkeleyDB::Hash',
	258	-Filename => $filename,
259	259	-Flags => DB_CREATE
260	260	or die "Cannot open $filename: $!\n" ;
261	261	while (($k, $v) = each %hash)

287	287	unlink $filename ;
288	288
289	289
290		my $db = tie %hash, 'BerkeleyDB::Btree',
291		-Filename => $filename,
	290	my $db = tie %hash, 'BerkeleyDB::Btree',
	291	-Filename => $filename,
292	292	-Flags => DB_CREATE
293	293	or die "Cannot open $filename: $!\n" ;
294	294

299	299	undef $db ;
300	300	untie %hash ;
301	301	## END intFilter
302		$db = tie %hash, 'BerkeleyDB::Btree',
303		-Filename => $filename,
	302	$db = tie %hash, 'BerkeleyDB::Btree',
	303	-Filename => $filename,
304	304	-Flags => DB_CREATE
305	305	or die "Cannot Open $filename: $!\n" ;
306	306	while (($k, $v) = each %hash)

334	334	unlink $filename ;
335	335
336	336	my @h ;
337		tie @h, 'BerkeleyDB::Recno',
338		-Filename => $filename,
	337	tie @h, 'BerkeleyDB::Recno',
	338	-Filename => $filename,
339	339	-Flags => DB_CREATE,
340	340	-Property => DB_RENUMBER
341	341	or die "Cannot open $filename: $!\n" ;

371	371	unlink $filename ;
372	372
373	373	my @h ;
374		my $db = tie @h, 'BerkeleyDB::Recno',
375		-Filename => $filename,
	374	my $db = tie @h, 'BerkeleyDB::Recno',
	375	-Filename => $filename,
376	376	-Flags => DB_CREATE,
377	377	-Property => DB_RENUMBER
378	378	or die "Cannot open $filename: $!\n" ;

413	413	EOM
414	414
415	415	}
416

+13

-15

t/examples3.t less more

0	0	#!./perl -w
1	1
2		use strict ;
	2	use strict ;
3	3
4	4	BEGIN {
5	5	unless(grep /blib/, @INC) {

9	9	}
10	10
11	11	use lib 't';
12		use BerkeleyDB;
	12	use BerkeleyDB;
13	13	use Test::More;
14	14	use util ;
15	15
16		#BEGIN
	16	#BEGIN
17	17	#{
18	18	# if ($BerkeleyDB::db_version < 3) {
19	19	# print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;

47	47
48	48	use strict ;
49	49	use BerkeleyDB ;
50
	50
51	51	my $filename = "fruit" ;
52	52	unlink $filename ;
53		my $db = new BerkeleyDB::Hash
54		-Filename => $filename,
	53	my $db = new BerkeleyDB::Hash
	54	-Filename => $filename,
55	55	-Flags => DB_CREATE,
56	56	-Property => DB_DUP
57	57	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

63	63	$db->db_put("yellow", "banana") ;
64	64	$db->db_put("red", "tomato") ;
65	65	$db->db_put("green", "apple") ;
66
	66
67	67	# print the contents of the file
68	68	my ($k, $v) = ("", "") ;
69	69	my $cursor = $db->db_cursor() ;
70	70	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
71	71	{ print "$k -> $v\n" }
72
	72
73	73	undef $cursor ;
74	74	undef $db ;
75	75	unlink $filename ;

95	95
96	96	use strict ;
97	97	use BerkeleyDB ;
98
	98
99	99	my $filename = "fruit" ;
100	100	unlink $filename ;
101		my $db = new BerkeleyDB::Hash
102		-Filename => $filename,
	101	my $db = new BerkeleyDB::Hash
	102	-Filename => $filename,
103	103	-Flags => DB_CREATE,
104	104	-Property => DB_DUP \| DB_DUPSORT
105	105	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

111	111	$db->db_put("yellow", "banana") ;
112	112	$db->db_put("red", "tomato") ;
113	113	$db->db_put("green", "apple") ;
114
	114
115	115	# print the contents of the file
116	116	my ($k, $v) = ("", "") ;
117	117	my $cursor = $db->db_cursor() ;
118	118	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
119	119	{ print "$k -> $v\n" }
120
	120
121	121	undef $cursor ;
122	122	undef $db ;
123	123	unlink $filename ;

134	134	EOM
135	135
136	136	}
137
138

+13

-15

t/examples3.t.T less more

0	0	#!./perl -w
1	1
2		use strict ;
	2	use strict ;
3	3
4	4	BEGIN {
5	5	unless(grep /blib/, @INC) {

9	9	}
10	10
11	11	use lib 't';
12		use BerkeleyDB;
	12	use BerkeleyDB;
13	13	use Test::More;
14	14	use util ;
15	15
16		#BEGIN
	16	#BEGIN
17	17	#{
18	18	# if ($BerkeleyDB::db_version < 3) {
19	19	# print "1..0 # Skipping test, this needs Berkeley DB 3.x or better\n" ;

48	48	## BEGIN dupHash
49	49	use strict ;
50	50	use BerkeleyDB ;
51
	51
52	52	my $filename = "fruit" ;
53	53	unlink $filename ;
54		my $db = new BerkeleyDB::Hash
55		-Filename => $filename,
	54	my $db = new BerkeleyDB::Hash
	55	-Filename => $filename,
56	56	-Flags => DB_CREATE,
57	57	-Property => DB_DUP
58	58	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

64	64	$db->db_put("yellow", "banana") ;
65	65	$db->db_put("red", "tomato") ;
66	66	$db->db_put("green", "apple") ;
67
	67
68	68	# print the contents of the file
69	69	my ($k, $v) = ("", "") ;
70	70	my $cursor = $db->db_cursor() ;
71	71	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
72	72	{ print "$k -> $v\n" }
73
	73
74	74	undef $cursor ;
75	75	undef $db ;
76	76	## END dupHash

98	98	## BEGIN dupSortHash
99	99	use strict ;
100	100	use BerkeleyDB ;
101
	101
102	102	my $filename = "fruit" ;
103	103	unlink $filename ;
104		my $db = new BerkeleyDB::Hash
105		-Filename => $filename,
	104	my $db = new BerkeleyDB::Hash
	105	-Filename => $filename,
106	106	-Flags => DB_CREATE,
107	107	-Property => DB_DUP \| DB_DUPSORT
108	108	or die "Cannot open file $filename: $! $BerkeleyDB::Error\n" ;

114	114	$db->db_put("yellow", "banana") ;
115	115	$db->db_put("red", "tomato") ;
116	116	$db->db_put("green", "apple") ;
117
	117
118	118	# print the contents of the file
119	119	my ($k, $v) = ("", "") ;
120	120	my $cursor = $db->db_cursor() ;
121	121	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
122	122	{ print "$k -> $v\n" }
123
	123
124	124	undef $cursor ;
125	125	undef $db ;
126	126	## END dupSortHash

138	138	EOM
139	139
140	140	}
141
142

+30

-31

t/filter.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

27	27	{
28	28	my($fk, $sk, $fv, $sv) = @_ ;
29	29	return
30		$fetch_key eq $fk && $store_key eq $sk &&
	30	$fetch_key eq $fk && $store_key eq $sk &&
31	31	$fetch_value eq $fv && $store_value eq $sv &&
32	32	$_ eq 'original' ;
33	33	}
34
35		ok $db = tie %h, 'BerkeleyDB::Hash',
36		-Filename => $Dfile,
37		-Flags => DB_CREATE;
	34
	35	ok $db = tie %h, 'BerkeleyDB::Hash',
	36	-Filename => $Dfile,
	37	-Flags => DB_CREATE;
38	38
39	39	$db->filter_fetch_key (sub { $fetch_key = $_ }) ;
40	40	$db->filter_store_key (sub { $store_key = $_ }) ;

58	58	ok checkOutput( "fred", "", "", "") ;
59	59
60	60	# replace the filters, but remember the previous set
61		my ($old_fk) = $db->filter_fetch_key
	61	my ($old_fk) = $db->filter_fetch_key
62	62	(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
63		my ($old_sk) = $db->filter_store_key
	63	my ($old_sk) = $db->filter_store_key
64	64	(sub { $_ = lc $_ ; $store_key = $_ }) ;
65		my ($old_fv) = $db->filter_fetch_value
	65	my ($old_fv) = $db->filter_fetch_value
66	66	(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
67		my ($old_sv) = $db->filter_store_value
	67	my ($old_sv) = $db->filter_store_value
68	68	(sub { s/o/x/g; $store_value = $_ }) ;
69
	69
70	70	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
71	71	$h{"Fred"} = "Joe" ;
72	72	# fk sk fv sv

124	124	unlink $Dfile;
125	125	}
126	126
127		{
	127	{
128	128	# DBM Filter with a closure
129	129
130	130	use strict ;
131	131	my (%h, $db) ;
132	132
133	133	unlink $Dfile;
134		ok $db = tie %h, 'BerkeleyDB::Hash',
135		-Filename => $Dfile,
136		-Flags => DB_CREATE;
	134	ok $db = tie %h, 'BerkeleyDB::Hash',
	135	-Filename => $Dfile,
	136	-Flags => DB_CREATE;
137	137
138	138	my %result = () ;
139	139

143	143	my $count = 0 ;
144	144	my @kept = () ;
145	145
146		return sub { ++$count ;
147		push @kept, $_ ;
	146	return sub { ++$count ;
	147	push @kept, $_ ;
148	148	$result{$name} = "$name - $count: [@kept]" ;
149	149	}
150	150	}

187	187	undef $db ;
188	188	untie %h;
189	189	unlink $Dfile;
190		}
	190	}
191	191
192	192	{
193	193	# DBM Filter recursion detection

195	195	my (%h, $db) ;
196	196	unlink $Dfile;
197	197
198		ok $db = tie %h, 'BerkeleyDB::Hash',
199		-Filename => $Dfile,
200		-Flags => DB_CREATE;
	198	ok $db = tie %h, 'BerkeleyDB::Hash',
	199	-Filename => $Dfile,
	200	-Flags => DB_CREATE;
201	201
202	202	$db->filter_store_key (sub { $_ = $h{$_} }) ;
203	203
204	204	eval '$h{1} = 1234' ;
205	205	ok $@ =~ /^recursion detected in filter_store_key at/ ;
206
	206
207	207	undef $db ;
208	208	untie %h;
209	209	unlink $Dfile;

217	217	my (%h, $db) ;
218	218	unlink $Dfile;
219	219
220		ok $db = tie %h, 'BerkeleyDB::Hash',
221		-Filename => $Dfile,
222		-Flags => DB_CREATE;
	220	ok $db = tie %h, 'BerkeleyDB::Hash',
	221	-Filename => $Dfile,
	222	-Flags => DB_CREATE;
223	223
224	224	$db->filter_fetch_key (sub { }) ;
225	225	$db->filter_store_key (sub { }) ;

246	246	ok($h{"fred"} eq "joe");
247	247
248	248	ok($db->FIRSTKEY() eq "fred") ;
249
	249
250	250	eval { grep { $h{$_} } (1, 2, 3) };
251	251	ok (! $@);
252	252

262	262	my (%h, $db) ;
263	263
264	264	unlink $Dfile;
265		ok $db = tie %h, 'BerkeleyDB::Hash',
266		-Filename => $Dfile,
267		-Flags => DB_CREATE;
	265	ok $db = tie %h, 'BerkeleyDB::Hash',
	266	-Filename => $Dfile,
	267	-Flags => DB_CREATE;
268	268
269	269	my %result = () ;
270	270

322	322	untie %h;
323	323	unlink $Dfile;
324	324	}
325

+38

-38

t/hash.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

44	44	{
45	45	my $lex = new LexFile $Dfile ;
46	46
47		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	47	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
48	48	-Flags => DB_CREATE ;
49	49
50	50	# Add a k/v pair

100	100
101	101	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\| DB_INIT_MPOOL,@StdErrFile,
102	102	-Home => $home ;
103		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	103	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
104	104	-Env => $env,
105	105	-Flags => DB_CREATE ;
106	106
107	107	isa_ok $db->Env, 'BerkeleyDB::Env';
108
	108
109	109	# Add a k/v pair
110	110	my $value ;
111	111	ok $db->db_put("some key", "some value") == 0 ;

121	121	my $lex = new LexFile $Dfile ;
122	122	my $value ;
123	123	$::count = 0 ;
124		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	124	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
125	125	-Hash => sub { ++$::count ; length $_[0] },
126	126	-Flags => DB_CREATE ;
127	127

131	131	ok $::count > 0 ;
132	132
133	133	}
134
	134
135	135	{
136	136	# cursors
137	137
138	138	my $lex = new LexFile $Dfile ;
139	139	my %hash ;
140	140	my ($k, $v) ;
141		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	141	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
142	142	-Flags => DB_CREATE ;
143	143
144	144	# create some data

162	162	my $extras = 0 ;
163	163	# sequence forwards
164	164	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
165		if ( $copy{$k} eq $v )
	165	if ( $copy{$k} eq $v )
166	166	{ delete $copy{$k} }
167	167	else
168	168	{ ++ $extras }

179	179	for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
180	180	$status == 0 ;
181	181	$status = $cursor->c_get($k, $v, DB_PREV)) {
182		if ( $copy{$k} eq $v )
	182	if ( $copy{$k} eq $v )
183	183	{ delete $copy{$k} }
184	184	else
185	185	{ ++ $extras }

199	199
200	200	($k, $v) = ("black", "house") ;
201	201	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
202
203		}
204
	202
	203	}
	204
205	205	{
206	206	# Tied Hash interface
207	207

277	277	undef $db ;
278	278	untie %hash ;
279	279	}
280
	280
281	281	{
282	282	# partial
283	283	# check works via API

362	362
363	363	{
364	364	# partial
365		# check works via tied hash
	365	# check works via tied hash
366	366
367	367	my $lex = new LexFile $Dfile ;
368	368	my %hash ;

529	529	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
530	530	ok $key eq "Wall" && $value eq "Brick" ;
531	531
532		#my $ref = $db->db_stat() ;
	532	#my $ref = $db->db_stat() ;
533	533	#ok $ref->{bt_flags} \| DB_DUP ;
534	534
535	535	# test DB_DUP_NEXT

543	543	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
544	544	ok $k eq "Wall" && $v eq "Brick" ;
545	545	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
546
	546
547	547
548	548	undef $db ;
549	549	undef $cursor ;

556	556	my $lex = new LexFile $Dfile, $Dfile2;
557	557	my ($key, $value) ;
558	558	my (%h, %g) ;
559		my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
560		my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
561
562		ok tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
	559	my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
	560	my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
	561
	562	ok tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
563	563	-DupCompare => sub { $_[0] cmp $_[1] },
564	564	-Property => DB_DUP\|DB_DUPSORT,
565	565	-Flags => DB_CREATE ;
566	566
567		ok tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
	567	ok tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
568	568	-DupCompare => sub { $_[0] <=> $_[1] },
569	569	-Property => DB_DUP\|DB_DUPSORT,
570	570	-Flags => DB_CREATE ;

572	572	foreach (@Keys) {
573	573	local $^W = 0 ;
574	574	my $value = shift @Values ;
575		$h{$_} = $value ;
	575	$h{$_} = $value ;
576	576	$g{$_} = $value ;
577	577	}
578	578

602	602	my $lex = new LexFile $Dfile;
603	603	my %hh ;
604	604
605		ok my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
	605	ok my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
606	606	-DupCompare => sub { $_[0] cmp $_[1] },
607	607	-Property => DB_DUP,
608	608	-Flags => DB_CREATE ;

612	612	$hh{'Wall'} = 'Brick' ; # Note the duplicate key
613	613	$hh{'Smith'} = 'John' ;
614	614	$hh{'mouse'} = 'mickey' ;
615
	615
616	616	# first work in scalar context
617	617	ok scalar $YY->get_dup('Unknown') == 0 ;
618	618	ok scalar $YY->get_dup('Smith') == 1 ;
619	619	ok scalar $YY->get_dup('Wall') == 3 ;
620
	620
621	621	# now in list context
622	622	my @unknown = $YY->get_dup('Unknown') ;
623	623	ok "@unknown" eq "" ;
624
	624
625	625	my @smith = $YY->get_dup('Smith') ;
626	626	ok "@smith" eq "John" ;
627
	627
628	628	{
629	629	my @wall = $YY->get_dup('Wall') ;
630	630	my %wall ;
631	631	@wall{@wall} = @wall ;
632		ok (@wall == 3 && $wall{'Larry'}
	632	ok (@wall == 3 && $wall{'Larry'}
633	633	&& $wall{'Stone'} && $wall{'Brick'});
634	634	}
635
	635
636	636	# hash
637	637	my %unknown = $YY->get_dup('Unknown', 1) ;
638	638	ok keys %unknown == 0 ;
639
	639
640	640	my %smith = $YY->get_dup('Smith', 1) ;
641	641	ok keys %smith == 1 && $smith{'John'} ;
642
	642
643	643	my %wall = $YY->get_dup('Wall', 1) ;
644		ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
	644	ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
645	645	&& $wall{'Brick'} == 1 ;
646
	646
647	647	undef $YY ;
648	648	untie %hh ;
649	649

669	669	@ISA=qw(BerkeleyDB BerkeleyDB::Hash);
670	670	@EXPORT = @BerkeleyDB::EXPORT ;
671	671
672		sub db_put {
	672	sub db_put {
673	673	my $self = shift ;
674	674	my $key = shift ;
675	675	my $value = shift ;
676	676	$self->SUPER::db_put($key, $value * 3) ;
677	677	}
678	678
679		sub db_get {
	679	sub db_get {
680	680	my $self = shift ;
681	681	$self->SUPER::db_get($_[0], $_[1]) ;
682	682	$_[1] -= 2 ;

696	696	close FILE ;
697	697
698	698	use Test::More;
699		BEGIN { push @INC, '.'; }
	699	BEGIN { push @INC, '.'; }
700	700	eval 'use SubDB ; ';
701	701	ok $@ eq "" ;
702	702	my %h ;
703	703	my $X ;
704	704	eval '
705		$X = tie(%h, "SubDB", -Filename => "dbhash.tmp",
	705	$X = tie(%h, "SubDB", -Filename => "dbhash.tmp",
706	706	-Flags => DB_CREATE,
707	707	-Mode => 0640 );
708	708	' ;

+27

-29

t/heap.t less more

2	2	use strict ;
3	3
4	4	use lib 't';
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7	use Test::More;
8	8

31	31	ok $@ =~ /unknown key value$s$ Stupid/ ;
32	32
33	33	eval ' $db = new BerkeleyDB::Heap -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
34		ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
	34	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
35	35	or print "# $@" ;
36	36
37	37	eval ' $db = new BerkeleyDB::Heap -Env => 2 ' ;

60	60	{
61	61	my $lex = new LexFile $Dfile ;
62	62
63		ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
64		-Flags => DB_CREATE
	63	ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
	64	-Flags => DB_CREATE
65	65	or diag "Cannot create Heap: [$!][$BerkeleyDB::Error]\n" ;
66	66
67	67	# Add a k/v pair

70	70	my $key1;
71	71	my $key2;
72	72	is $db->Env, undef;
73		ok $db->db_put($key1, "some value", DB_APPEND) == 0
	73	ok $db->db_put($key1, "some value", DB_APPEND) == 0
74	74	or diag "Cannot db_put: " . $db->status() . "[$!][$BerkeleyDB::Error]\n" ;
75	75	ok $db->status() == 0 ;
76		ok $db->db_get($key1, $value) == 0
	76	ok $db->db_get($key1, $value) == 0
77	77	or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
78	78	ok $value eq "some value" ;
79	79	ok $db->db_put($key2, "value", DB_APPEND) == 0 ;
80		ok $db->db_get($key2, $value) == 0
	80	ok $db->db_get($key2, $value) == 0
81	81	or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
82	82	ok $value eq "value" ;
83	83	ok $db->db_del($key1) == 0 ;
84	84	ok $db->db_get($key1, $value) == DB_NOTFOUND ;
85	85	ok $db->status() == DB_NOTFOUND ;
86		ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
	86	ok $db->status() =~ $DB_errors{'DB_NOTFOUND'}
87	87	or diag "Status is [" . $db->status() . "]";
88	88
89	89	ok $db->db_sync() == 0 ;

124	124
125	125	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
126	126	@StdErrFile, -Home => $home ;
127		ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
	127	ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
128	128	-Env => $env,
129	129	-Flags => DB_CREATE ;
130	130

141	141	undef $env ;
142	142	}
143	143
144
	144
145	145	{
146	146	# cursors
147	147
148	148	my $lex = new LexFile $Dfile ;
149	149	my %hash ;
150	150	my ($k, $v) ;
151		ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
	151	ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
152	152	-Flags => DB_CREATE ;
153		#print "[$db] [$!] $BerkeleyDB::Error\n" ;
	153	#print "[$db] [$!] $BerkeleyDB::Error\n" ;
154	154
155	155	# create some data
156	156	my %data = ();

174	174	my $extras = 0 ;
175	175	# sequence forwards
176	176	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
177		if ( $copy{$k} eq $v )
	177	if ( $copy{$k} eq $v )
178	178	{ delete $copy{$k} }
179	179	else
180	180	{ ++ $extras }

191	191	for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
192	192	$status == 0 ;
193	193	$status = $cursor->c_get($k, $v, DB_PREV)) {
194		if ( $copy{$k} eq $v )
	194	if ( $copy{$k} eq $v )
195	195	{ delete $copy{$k} }
196	196	else
197	197	{ ++ $extras }

213	213	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
214	214
215	215	}
216
	216
217	217
218	218
219	219

225	225	my $fd ;
226	226	my $value ;
227	227	#ok my $db = tie %hash, 'BerkeleyDB::Heap' ;
228		my $db = new BerkeleyDB::Heap
	228	my $db = new BerkeleyDB::Heap
229	229	-Flags => DB_CREATE ;
230	230
231	231	isa_ok $db, 'BerkeleyDB::Heap' ;

235	235	ok $value eq "some value", "some value" ;
236	236
237	237	}
238
	238
239	239	if (0)
240	240	{
241	241	# partial

352	352	ok ((my $Z = $txn->txn_commit()) == 0) ;
353	353	ok $txn = $env->txn_begin() ;
354	354	$db1->Txn($txn);
355
	355
356	356	# create some data
357	357	my %data = (
358	358	"red" => "boat",

432	432	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
433	433	ok $key eq "Wall" && $value eq "Brick" ;
434	434
435		#my $ref = $db->db_stat() ;
	435	#my $ref = $db->db_stat() ;
436	436	#ok ($ref->{bt_flags} \| DB_DUP) == DB_DUP ;
437	437	#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
438	438

449	449	my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
450	450	my %hash ;
451	451	my ($k, $v) ;
452		ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
	452	ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
453	453	-Flags => DB_CREATE,
454	454	-Minkey =>3 ,
455		-Pagesize => 2 **12
	455	-Pagesize => 2 **12
456	456	;
457	457
458		my $ref = $db->db_stat() ;
	458	my $ref = $db->db_stat() ;
459	459	ok $ref->{$recs} == 0;
460	460	ok $ref->{'bt_minkey'} == 3;
461	461	ok $ref->{'bt_pagesize'} == 2 ** 12;

473	473	}
474	474	ok $ret == 0 ;
475	475
476		$ref = $db->db_stat() ;
	476	$ref = $db->db_stat() ;
477	477	ok $ref->{$recs} == 3;
478	478	}
479	479

497	497	@ISA=qw(BerkeleyDB BerkeleyDB::Heap );
498	498	@EXPORT = @BerkeleyDB::EXPORT ;
499	499
500		sub db_put {
	500	sub db_put {
501	501	my $self = shift ;
502	502	my $key = shift ;
503	503	my $value = shift ;
504	504	$self->SUPER::db_put($key, $value * 3) ;
505	505	}
506	506
507		sub db_get {
	507	sub db_get {
508	508	my $self = shift ;
509	509	$self->SUPER::db_get($_[0], $_[1]) ;
510	510	$_[1] -= 2 ;

524	524	close FILE ;
525	525
526	526	use Test::More;
527		BEGIN { push @INC, '.'; }
	527	BEGIN { push @INC, '.'; }
528	528	eval 'use SubDB ; ';
529	529	ok $@ eq "" ;
530	530	my %h ;
531	531	my $X ;
532	532	eval '
533		$X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
	533	$X = tie(%h, "SubDB", -Filename => "dbbtree.tmp",
534	534	-Flags => DB_CREATE,
535	535	-Mode => 0640 );
536	536	' ;

559	559	unlink "SubDB.pm", "dbbtree.tmp" ;
560	560
561	561	}
562
563

+13

-13

t/join.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't';
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

12	12	plan(skip_all => "this needs BerkeleyDB 2.5.2 or better" )
13	13	if $BerkeleyDB::db_ver < 2.005002;
14	14
15		plan tests => 42;
	15	plan tests => 42;
16	16	}
17	17
18	18	my $Dfile1 = "dbhash1.tmp";

30	30	my $status ;
31	31	my $cursor ;
32	32
33		ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
	33	ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
34	34	-Filename => $Dfile1,
35	35	-Flags => DB_CREATE,
36	36	-DupCompare => sub { $_[0] lt $_[1] },

78	78	\|DB_INIT_MPOOL;
79	79	#\|DB_INIT_MPOOL\| DB_INIT_LOCK;
80	80	ok my $txn = $env->txn_begin() ;
81		ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
	81	ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
82	82	-Filename => $Dfile1,
83	83	-Flags => DB_CREATE,
84	84	-DupCompare => sub { $_[0] cmp $_[1] },

87	87	-Txn => $txn ;
88	88	;
89	89
90		ok my $db2 = tie %hash2, 'BerkeleyDB::Hash',
	90	ok my $db2 = tie %hash2, 'BerkeleyDB::Hash',
91	91	-Filename => $Dfile2,
92	92	-Flags => DB_CREATE,
93	93	-DupCompare => sub { $_[0] cmp $_[1] },

95	95	-Env => $env,
96	96	-Txn => $txn ;
97	97
98		ok my $db3 = tie %hash3, 'BerkeleyDB::Btree',
	98	ok my $db3 = tie %hash3, 'BerkeleyDB::Btree',
99	99	-Filename => $Dfile3,
100	100	-Flags => DB_CREATE,
101	101	-DupCompare => sub { $_[0] cmp $_[1] },

103	103	-Env => $env,
104	104	-Txn => $txn ;
105	105
106
	106
107	107	ok addData($db1, qw( apple Convenience
108	108	peach Shopway
109	109	pear Farmer

144	144
145	145	# sequence forwards
146	146	while ($cursor1->c_get($k, $v) == 0) {
147		delete $expected{$k}
	147	delete $expected{$k}
148	148	if defined $expected{$k} && $expected{$k} eq $v ;
149	149	#print "[$k] [$v]\n" ;
150	150	}

169	169
170	170	# sequence forwards
171	171	while ($cursor1->c_get($k, $v) == 0) {
172		delete $expected{$k}
	172	delete $expected{$k}
173	173	if defined $expected{$k} && $expected{$k} eq $v ;
174	174	#print "[$k] [$v]\n" ;
175	175	}

182	182	$k = "red" ;
183	183	$v = "" ;
184	184	ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
185
	185
186	186	ok $cursor3 = $db3->db_cursor() ;
187	187	$k = "expensive" ;
188	188	$v = "" ;
189	189	ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
190	190	ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
191
	191
192	192	%expected = qw( apple 1
193	193	strawberry 1
194	194	) ;
195
	195
196	196	# sequence forwards
197	197	$k = "" ;
198	198	$v = "" ;

+10

-10

t/mldbm.t less more

4	4	use lib 't';
5	5	use Test::More ;
6	6
7		BEGIN
	7	BEGIN
8	8	{
9	9	plan skip_all => "this is Perl $], skipping test\n"
10	10	if $] < 5.005 ;

24	24	plan skip_all => "MLDBM is not installed on this system.\n";
25	25	}
26	26
27		plan tests => 12;
	27	plan tests => 12;
28	28	}
29	29
30	30	use lib 't' ;

32	32
33	33	{
34	34	package BTREE ;
35
	35
36	36	use BerkeleyDB ;
37		use MLDBM qw(BerkeleyDB::Btree) ;
	37	use MLDBM qw(BerkeleyDB::Btree) ;
38	38	use Data::Dumper;
39	39	use Test::More;
40
	40
41	41	my $filename = "";
42	42	my $lex = new LexFile $filename;
43
	43
44	44	$MLDBM::UseDB = "BerkeleyDB::Btree" ;
45	45	my %o ;
46	46	my $db = tie %o, 'MLDBM', -Filename => $filename,

48	48	or die $!;
49	49	ok $db ;
50	50	ok $db->type() == DB_BTREE ;
51
	51
52	52	my $c = [\'c'];
53	53	my $b = {};
54	54	my $a = [1, $b, $c];

59	59	$o{d} = "{once upon a time}";
60	60	$o{e} = 1024;
61	61	$o{f} = 1024.1024;
62
	62
63	63	my $struct = [@o{qw(a b c)}];
64	64	ok ::_compare([$a, $b, $c], $struct);
65	65	ok $o{d} eq "{once upon a time}" ;
66	66	ok $o{e} == 1024 ;
67	67	ok $o{f} eq 1024.1024 ;
68
	68
69	69	}
70	70
71	71	{

73	73	package HASH ;
74	74
75	75	use BerkeleyDB ;
76		use MLDBM qw(BerkeleyDB::Hash) ;
	76	use MLDBM qw(BerkeleyDB::Hash) ;
77	77	use Data::Dumper;
78	78
79	79	my $filename = "";

+40

-40

t/queue.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use Test::More;
9	9	use util;
10	10
11	11	plan(skip_all => "Queue needs Berkeley DB 3.3.x or better\n" )
12	12	if $BerkeleyDB::db_version < 3.3;
13
	13
14	14	plan tests => 260;
15	15
16	16

50	50	my $rec_len = 10 ;
51	51	my $pad = "x" ;
52	52
53		ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
	53	ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
54	54	-Flags => DB_CREATE,
55	55	-Len => $rec_len,
56	56	-Pad => $pad;

108	108
109	109	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,@StdErrFile,
110	110	-Home => $home ;
111		ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
	111	ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
112	112	-Env => $env,
113	113	-Flags => DB_CREATE,
114	114	-Len => $rec_len;
115	115
116	116	isa_ok $db->Env, 'BerkeleyDB::Env';
117
	117
118	118	# Add a k/v pair
119	119	my $value ;
120	120	ok $db->db_put(1, "some value") == 0 ;

124	124	undef $env ;
125	125	}
126	126
127
	127
128	128	{
129	129	# cursors
130	130

132	132	my @array ;
133	133	my ($k, $v) ;
134	134	my $rec_len = 5 ;
135		ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
	135	ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
136	136	-ArrayBase => 0,
137	137	-Flags => DB_CREATE ,
138	138	-Len => $rec_len;

160	160	my %copy = %data;
161	161	my $extras = 0 ;
162	162	# sequence forwards
163		while ($cursor->c_get($k, $v, DB_NEXT) == 0)
	163	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
164	164	{
165		if ( fillout($copy{$k}, $rec_len) eq $v )
	165	if ( fillout($copy{$k}, $rec_len) eq $v )
166	166	{ delete $copy{$k} }
167	167	else
168	168	{ ++ $extras }

180	180	for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
181	181	$status == 0 ;
182	182	$status = $cursor->c_get($k, $v, DB_PREV)) {
183		if ( fillout($copy{$k}, $rec_len) eq $v )
	183	if ( fillout($copy{$k}, $rec_len) eq $v )
184	184	{ delete $copy{$k} }
185	185	else
186	186	{ ++ $extras }

192	192	ok keys %copy == 0 ;
193	193	ok $extras == 0 ;
194	194	}
195
	195
196	196	{
197	197	# Tied Array interface
198	198

246	246
247	247	# unshift isn't allowed
248	248	# eval {
249		# $FA ? unshift @array, "red", "green", "blue"
	249	# $FA ? unshift @array, "red", "green", "blue"
250	250	# : $db->unshift("red", "green", "blue" ) ;
251	251	# } ;
252		# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
	252	# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
253	253	$array[0] = "red" ;
254	254	$array[1] = "green" ;
255	255	$array[2] = "blue" ;

278	278	ok (($FA ? shift @array : $db->shift()) == 2) ;
279	279
280	280	# push
281		$FA ? push @array, "the", "end"
	281	$FA ? push @array, "the", "end"
282	282	: $db->push("the", "end") ;
283	283	ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
284	284	ok $k == 102 ;

297	297
298	298	undef $cursor;
299	299
300		# now clear the array
301		$FA ? @array = ()
	300	# now clear the array
	301	$FA ? @array = ()
302	302	: $db->clear() ;
303	303	ok $cursor = (tied @array)->db_cursor() ;
304	304	ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;

323	323	ok $value eq fillout("some value", $rec_len) ;
324	324
325	325	}
326
	326
327	327	{
328	328	# partial
329	329	# check works via API

413	413
414	414	{
415	415	# partial
416		# check works via tied array
	416	# check works via tied array
417	417
418	418	my $lex = new LexFile $Dfile ;
419	419	my @array ;

508	508	-Flags => DB_CREATE\|DB_INIT_TXN\|
509	509	DB_INIT_MPOOL\|DB_INIT_LOCK ;
510	510	ok my $txn = $env->txn_begin() ;
511		ok my $db1 = tie @array, 'BerkeleyDB::Queue',
	511	ok my $db1 = tie @array, 'BerkeleyDB::Queue',
512	512	-Filename => $Dfile,
513	513	-ArrayBase => 0,
514	514	-Flags => DB_CREATE ,

517	517	-Len => $rec_len,
518	518	-Pad => " " ;
519	519
520
	520
521	521	ok $txn->txn_commit() == 0 ;
522	522	ok $txn = $env->txn_begin() ;
523	523	$db1->Txn($txn);

576	576	my @array ;
577	577	my ($k, $v) ;
578	578	my $rec_len = 7 ;
579		ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
	579	ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
580	580	-Flags => DB_CREATE,
581	581	-Pagesize => 4 * 1024,
582	582	-Len => $rec_len,
583		-Pad => " "
	583	-Pad => " "
584	584	;
585	585
586		my $ref = $db->db_stat() ;
	586	my $ref = $db->db_stat() ;
587	587	ok $ref->{$recs} == 0;
588	588	ok $ref->{'qs_pagesize'} == 4 * 1024;
589	589

601	601	}
602	602	ok $ret == 0 ;
603	603
604		$ref = $db->db_stat() ;
	604	$ref = $db->db_stat() ;
605	605	ok $ref->{$recs} == 3;
606	606	}
607	607

625	625	@ISA=qw(BerkeleyDB BerkeleyDB::Queue);
626	626	@EXPORT = @BerkeleyDB::EXPORT ;
627	627
628		sub db_put {
	628	sub db_put {
629	629	my $self = shift ;
630	630	my $key = shift ;
631	631	my $value = shift ;
632	632	$self->SUPER::db_put($key, $value * 3) ;
633	633	}
634	634
635		sub db_get {
	635	sub db_get {
636	636	my $self = shift ;
637	637	$self->SUPER::db_get($_[0], $_[1]) ;
638	638	$_[1] -= 2 ;

652	652	close FILE ;
653	653
654	654	use Test::More;
655		BEGIN { push @INC, '.'; }
	655	BEGIN { push @INC, '.'; }
656	656	eval 'use SubDB ; ';
657	657	ok $@ eq "" ;
658	658	my @h ;
659	659	my $X ;
660	660	my $rec_len = 34 ;
661	661	eval '
662		$X = tie(@h, "SubDB", -Filename => "dbqueue.tmp",
	662	$X = tie(@h, "SubDB", -Filename => "dbqueue.tmp",
663	663	-Flags => DB_CREATE,
664	664	-Mode => 0640 ,
665	665	-Len => $rec_len,
666		-Pad => " "
667		);
	666	-Pad => " "
	667	);
668	668	' ;
669	669
670	670	ok $@ eq "" ;

699	699	my @array ;
700	700	my $value ;
701	701	my $rec_len = 21 ;
702		ok my $db = tie @array, 'BerkeleyDB::Queue',
	702	ok my $db = tie @array, 'BerkeleyDB::Queue',
703	703	-Filename => $Dfile,
704	704	-Flags => DB_CREATE ,
705	705	-Len => $rec_len,

724	724	my @array ;
725	725	my $db ;
726	726	my $rec_len = 21 ;
727		ok $db = tie @array, 'BerkeleyDB::Queue',
	727	ok $db = tie @array, 'BerkeleyDB::Queue',
728	728	-Flags => DB_CREATE ,
729	729	-ArrayBase => 0,
730	730	-Len => $rec_len,

805	805
806	806	# unshift isn't allowed
807	807	# eval {
808		# $FA ? unshift @array, "red", "green", "blue"
	808	# $FA ? unshift @array, "red", "green", "blue"
809	809	# : $db->unshift("red", "green", "blue" ) ;
810	810	# } ;
811		# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
	811	# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
812	812	$array[0] = "red" ;
813	813	$array[1] = "green" ;
814	814	$array[2] = "blue" ;

837	837	ok (($FA ? shift @array : $db->shift()) == 2) ;
838	838
839	839	# push
840		$FA ? push @array, "the", "end"
	840	$FA ? push @array, "the", "end"
841	841	: $db->push("the", "end") ;
842	842	ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
843	843	ok $k == 102 ;

855	855	ok (( $FA ? pop @array : $db->pop ) == 200 ) ;
856	856
857	857	undef $cursor ;
858		# now clear the array
859		$FA ? @array = ()
	858	# now clear the array
	859	$FA ? @array = ()
860	860	: $db->clear() ;
861	861	ok $cursor = (tied @array)->db_cursor() ;
862	862	ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;

872	872	my $lex = new LexFile $Dfile ;
873	873	my @array ;
874	874	my $db ;
875		$db = tie @array, 'BerkeleyDB::Queue',
	875	$db = tie @array, 'BerkeleyDB::Queue',
876	876	-Flags => DB_CREATE ,
877	877	-Len => 2,
878	878	-Filename => $Dfile ;
879		isa_ok $db, 'BerkeleyDB::Queue';
	879	isa_ok $db, 'BerkeleyDB::Queue';
880	880	$FA ? push @array, "ab", "cd", "ef", "gh"
881	881	: $db->push("ab", "cd", "ef", "gh") ;
882	882	is scalar(@array), 4;

+33

-33

t/recno.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10

43	43	{
44	44	my $lex = new LexFile $Dfile ;
45	45
46		ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	46	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
47	47	-Flags => DB_CREATE ;
48	48
49	49	is $db->Env, undef;

96	96	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,@StdErrFile,
97	97	-Home => $home ;
98	98
99		ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	99	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
100	100	-Env => $env,
101	101	-Flags => DB_CREATE ;
102	102
103	103	isa_ok $db->Env, 'BerkeleyDB::Env';
104
	104
105	105	# Add a k/v pair
106	106	my $value ;
107	107	ok $db->db_put(1, "some value") == 0 ;

111	111	undef $env ;
112	112	}
113	113
114
	114
115	115	{
116	116	# cursors
117	117
118	118	my $lex = new LexFile $Dfile ;
119	119	my @array ;
120	120	my ($k, $v) ;
121		ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	121	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
122	122	-ArrayBase => 0,
123	123	-Flags => DB_CREATE ;
124	124

145	145	my %copy = %data;
146	146	my $extras = 0 ;
147	147	# sequence forwards
148		while ($cursor->c_get($k, $v, DB_NEXT) == 0)
	148	while ($cursor->c_get($k, $v, DB_NEXT) == 0)
149	149	{
150		if ( $copy{$k} eq $v )
	150	if ( $copy{$k} eq $v )
151	151	{ delete $copy{$k} }
152	152	else
153	153	{ ++ $extras }

165	165	for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
166	166	$status == 0 ;
167	167	$status = $cursor->c_get($k, $v, DB_PREV)) {
168		if ( $copy{$k} eq $v )
	168	if ( $copy{$k} eq $v )
169	169	{ delete $copy{$k} }
170	170	else
171	171	{ ++ $extras }

177	177	ok keys %copy == 0 ;
178	178	ok $extras == 0 ;
179	179	}
180
	180
181	181	{
182	182	# Tied Array interface
183	183

235	235	ok $values == 2022 ;
236	236
237	237	# unshift
238		$FA ? unshift @array, "red", "green", "blue"
	238	$FA ? unshift @array, "red", "green", "blue"
239	239	: $db->unshift("red", "green", "blue" ) ;
240	240	ok $array[1] eq "red" ;
241	241	ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;

261	261	ok (($FA ? shift @array : $db->shift()) == 2) ;
262	262
263	263	# push
264		$FA ? push @array, "the", "end"
	264	$FA ? push @array, "the", "end"
265	265	: $db->push("the", "end") ;
266	266	ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
267	267	ok $k == 1001 ;

279	279	ok (( $FA ? pop @array : $db->pop ) == 2000) ;
280	280
281	281	undef $cursor;
282		# now clear the array
283		$FA ? @array = ()
	282	# now clear the array
	283	$FA ? @array = ()
284	284	: $db->clear() ;
285	285	ok $cursor = $db->db_cursor() ;
286	286	ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;

303	303	ok $value eq "some value" ;
304	304
305	305	}
306
	306
307	307	{
308	308	# partial
309	309	# check works via API

389	389
390	390	{
391	391	# partial
392		# check works via tied array
	392	# check works via tied array
393	393
394	394	my $lex = new LexFile $Dfile ;
395	395	my @array ;

469	469	-Flags => DB_CREATE\|DB_INIT_TXN\|
470	470	DB_INIT_MPOOL\|DB_INIT_LOCK ;
471	471	ok my $txn = $env->txn_begin() ;
472		ok my $db1 = tie @array, 'BerkeleyDB::Recno',
	472	ok my $db1 = tie @array, 'BerkeleyDB::Recno',
473	473	-Filename => $Dfile,
474	474	-ArrayBase => 0,
475	475	-Flags => DB_CREATE ,
476	476	-Env => $env,
477	477	-Txn => $txn ;
478	478
479
	479
480	480	ok $txn->txn_commit() == 0 ;
481	481	ok $txn = $env->txn_begin() ;
482	482	$db1->Txn($txn);

534	534	my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
535	535	my @array ;
536	536	my ($k, $v) ;
537		ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	537	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
538	538	-Flags => DB_CREATE,
539	539	-Pagesize => 4 * 1024,
540	540	;
541	541
542		my $ref = $db->db_stat() ;
	542	my $ref = $db->db_stat() ;
543	543	ok $ref->{$recs} == 0;
544	544	ok $ref->{'bt_pagesize'} == 4 * 1024;
545	545

557	557	}
558	558	ok $ret == 0 ;
559	559
560		$ref = $db->db_stat() ;
	560	$ref = $db->db_stat() ;
561	561	ok $ref->{$recs} == 3;
562	562	}
563	563

581	581	@ISA=qw(BerkeleyDB BerkeleyDB::Recno);
582	582	@EXPORT = @BerkeleyDB::EXPORT ;
583	583
584		sub db_put {
	584	sub db_put {
585	585	my $self = shift ;
586	586	my $key = shift ;
587	587	my $value = shift ;
588	588	$self->SUPER::db_put($key, $value * 3) ;
589	589	}
590	590
591		sub db_get {
	591	sub db_get {
592	592	my $self = shift ;
593	593	$self->SUPER::db_get($_[0], $_[1]) ;
594	594	$_[1] -= 2 ;

607	607
608	608	close FILE ;
609	609
610		BEGIN { push @INC, '.'; }
	610	BEGIN { push @INC, '.'; }
611	611	use Test::More;
612	612	eval 'use SubDB ; ';
613	613	ok $@ eq "" ;
614	614	my @h ;
615	615	my $X ;
616	616	eval '
617		$X = tie(@h, "SubDB", -Filename => "dbrecno.tmp",
	617	$X = tie(@h, "SubDB", -Filename => "dbrecno.tmp",
618	618	-Flags => DB_CREATE,
619	619	-Mode => 0640 );
620	620	' ;

763	763	my $lex = new LexFile $Dfile;
764	764	my @array ;
765	765	my $value ;
766		ok my $db = tie @array, 'BerkeleyDB::Recno',
	766	ok my $db = tie @array, 'BerkeleyDB::Recno',
767	767	-Filename => $Dfile,
768	768	-Flags => DB_CREATE ;
769	769

806	806	touch $Dfile2 ;
807	807	my @array ;
808	808	my $value ;
809		ok tie @array, 'BerkeleyDB::Recno',
	809	ok tie @array, 'BerkeleyDB::Recno',
810	810	-ArrayBase => 0,
811	811	-Flags => DB_CREATE ,
812	812	-Source => $Dfile2 ,

849	849	touch $Dfile2 ;
850	850	my @array ;
851	851	my $value ;
852		ok tie @array, 'BerkeleyDB::Recno',
	852	ok tie @array, 'BerkeleyDB::Recno',
853	853	-ArrayBase => 0,
854	854	-Flags => DB_CREATE ,
855	855	-Property => DB_RENUMBER,

870	870	my $lex = new LexFile $Dfile ;
871	871	my @array ;
872	872	my $db ;
873		ok $db = tie @array, 'BerkeleyDB::Recno',
	873	ok $db = tie @array, 'BerkeleyDB::Recno',
874	874	-ArrayBase => 0,
875	875	-Flags => DB_CREATE ,
876	876	-Property => DB_RENUMBER,

891	891	my $lex = new LexFile $Dfile ;
892	892	my @array ;
893	893	my $db ;
894		ok $db = tie @array, 'BerkeleyDB::Recno',
	894	ok $db = tie @array, 'BerkeleyDB::Recno',
895	895	-ArrayBase => 0,
896	896	-Flags => DB_CREATE ,
897	897	-Property => DB_RENUMBER,

911	911	if(0)
912	912	{
913	913	# RT #75691: scalar(@array) returns incorrect value after shift() on tied array
914		skip "Test needs Berkeley DB 3.2 or better", 4
	914	skip "Test needs Berkeley DB 3.2 or better", 4
915	915	if $BerkeleyDB::db_version < 3.3;
916	916
917	917	my $lex = new LexFile $Dfile ;
918	918	my @array ;
919	919	my $db ;
920		ok $db = tie @array, 'BerkeleyDB::Recno',
	920	ok $db = tie @array, 'BerkeleyDB::Recno',
921	921	-Flags => DB_CREATE ,
922	922	-Filename => $Dfile ;
923	923

+3

-3

t/sequence.t less more

2	2
3	3	use lib 't' ;
4	4	use Test::More;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util;
7	7
8	8	plan(skip_all => "Sequence needs Berkeley DB 4.3.x or better\n" )
9	9	if $BerkeleyDB::db_version < 4.3;
10
	10
11	11	plan tests => 13;
12	12
13	13	{

24	24
25	25	my $db = BerkeleyDB::Btree->new(
26	26	Env => $env,
27		-Filename => $Dfile,
	27	-Filename => $Dfile,
28	28	-Flags => DB_CREATE
29	29	);
30	30

+8

-9

t/strict.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7
8	8	use Test::More ;
9	9
10		plan tests => 44;
	10	plan tests => 44;
11	11
12	12	my $Dfile = "dbhash.tmp";
13	13	my $home = "./fred" ;

24	24	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
25	25	-Flags => DB_CREATE\|DB_INIT_TXN\|
26	26	DB_INIT_MPOOL\|DB_INIT_LOCK ;
27
	27
28	28	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
29	29	-Flags => DB_CREATE ,
30	30	-Env => $env;
31	31
32		ok $db1->db_close() == 0 ;
	32	ok $db1->db_close() == 0 ;
33	33
34	34	eval { $status = $env->db_appexit() ; } ;
35	35	ok $status == 0 ;

47	47	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
48	48	-Flags => DB_CREATE\|DB_INIT_TXN\|
49	49	DB_INIT_MPOOL\|DB_INIT_LOCK ;
50
	50
51	51	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
52	52	-Flags => DB_CREATE ,
53	53	-Env => $env;

62	62	}
63	63
64	64	{
65		# closing a transaction & a database
	65	# closing a transaction & a database
66	66	my $lex = new LexFile $Dfile ;
67	67	my %hash ;
68	68	my $status ;

113	113	}
114	114
115	115	{
116		# closing a cursor & a database
	116	# closing a cursor & a database
117	117	my $lex = new LexFile $Dfile ;
118	118	my %hash ;
119	119	my $status ;

140	140	}
141	141
142	142	{
143		# closing a transaction & a cursor
	143	# closing a transaction & a cursor
144	144	my $lex = new LexFile $Dfile ;
145	145	my %hash ;
146	146	my $status ;

169	169	ok $@ eq "" ;
170	170	#print "[$@]\n" ;
171	171	}
172

+24

-24

t/subdb.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use Test::More ;
7	7	use util ;
8	8

37	37	ok $status == DB_NOTFOUND;
38	38
39	39	return wantarray ? sort @dbnames : scalar @dbnames ;
40
	40
41	41
42	42	}
43	43

72	72
73	73	my $lex = new LexFile $Dfile ;
74	74
75		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	75	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
76	76	-Flags => DB_CREATE ;
77	77
78	78	# Add a k/v pair

88	88
89	89	undef $db ;
90	90
91		$db = new BerkeleyDB::Hash -Filename => $Dfile,
	91	$db = new BerkeleyDB::Hash -Filename => $Dfile,
92	92	-Subname => "fred" ;
93		ok ! $db ;
	93	ok ! $db ;
94	94
95	95	ok -e $Dfile ;
96	96	ok ! BerkeleyDB::db_remove(-Filename => $Dfile) ;

104	104
105	105	my $lex = new LexFile $Dfile ;
106	106
107		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	107	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
108	108	-Subname => "fred" ,
109	109	-Flags => DB_CREATE ;
110	110

121	121
122	122	undef $db ;
123	123
124		$db = new BerkeleyDB::Hash -Filename => $Dfile,
	124	$db = new BerkeleyDB::Hash -Filename => $Dfile,
125	125	-Subname => "joe" ;
126	126
127		ok !$db ;
128
129		}
130
131		{
132		# subdatabases
133
134		my $lex = new LexFile $Dfile ;
135
136		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	127	ok !$db ;
	128
	129	}
	130
	131	{
	132	# subdatabases
	133
	134	my $lex = new LexFile $Dfile ;
	135
	136	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
137	137	-Subname => "fred" ,
138	138	-Flags => DB_CREATE ;
139	139

160	160	# of the subdatabase names
161	161
162	162	my $lex = new LexFile $Dfile ;
163
164		ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	163
	164	ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
165	165	-Subname => "fred" ,
166	166	-Flags => DB_CREATE ;
167	167
168		ok my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
	168	ok my $db2 = new BerkeleyDB::Btree -Filename => $Dfile,
169	169	-Subname => "joe" ,
170	170	-Flags => DB_CREATE ;
171	171

183	183
184	184	undef $db1 ;
185	185	undef $db2 ;
186
	186
187	187	is join(",", countDatabases($Dfile)), "fred,joe";
188	188
189	189	ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "harry") != 0;
190	190	ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") == 0 ;
191
	191
192	192	# should only be one subdatabase
193	193	is join(",", countDatabases($Dfile)), "joe";
194	194
195	195	# can't delete an already deleted subdatabase
196	196	ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "fred") != 0;
197
	197
198	198	ok BerkeleyDB::db_remove(-Filename => $Dfile, -Subname => "joe") == 0 ;
199
	199
200	200	# should only be one subdatabase
201	201	is countDatabases($Dfile), 0;
202	202

+6

-7

t/txn.t less more

2	2	use strict ;
3	3
4	4	use lib 't' ;
5		use BerkeleyDB;
	5	use BerkeleyDB;
6	6	use util ;
7	7
8	8	use Test::More ;
9	9
10		plan tests => 58;
	10	plan tests => 58;
11	11
12	12	my $Dfile = "dbhash.tmp";
13	13

51	51	-Env => $env,
52	52	-Txn => $txn ;
53	53
54
	54
55	55	ok $txn->txn_commit() == 0 ;
56	56	ok $txn = $env->txn_begin() ;
57	57	$db1->Txn($txn);

125	125	ok $txn->txn_commit() == 0 ;
126	126	ok $txn = $env->txn_begin() ;
127	127	$db1->Txn($txn);
128
	128
129	129	# create some data
130	130	my %data = (
131	131	"red" => "boat",

192	192	-Env => $env,
193	193	-Txn => $txn ;
194	194
195
	195
196	196	ok $txn->txn_commit() == 0 ;
197	197	ok $txn = $env->txn_begin() ;
198	198	$db1->Txn($txn);

265	265	ok $txn->txn_commit() == 0 ;
266	266	ok $txn = $env->txn_begin() ;
267	267	$db1->Txn($txn);
268
	268
269	269	# create some data
270	270	my %data = (
271	271	"red" => "boat",

312	312	undef $env ;
313	313	untie %hash ;
314	314	}
315

+19

-19

t/unknown.t less more

0	0	#!./perl -w
1	1
2		# ID: %I%, %G%
	2	# ID: %I%, %G%
3	3
4	4	use strict ;
5	5
6	6	use lib 't' ;
7		use BerkeleyDB;
	7	use BerkeleyDB;
8	8	use util ;
9	9	use Test::More;
10	10	plan tests => 50;

42	42	my $lex = new LexFile $Dfile ;
43	43	ok writeFile($Dfile, "") ;
44	44
45		ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
	45	ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
46	46
47	47	# now a non-database file
48	48	writeFile($Dfile, "\x2af6") ;
49		ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
	49	ok ! (new BerkeleyDB::Unknown -Filename => $Dfile);
50	50	}
51	51
52	52	# check the interface to a Hash database

55	55	my $lex = new LexFile $Dfile ;
56	56
57	57	# create a hash database
58		ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
59		-Flags => DB_CREATE ;
60
61		# Add a few k/v pairs
62		my $value ;
63		my $status ;
64		ok $db->db_put("some key", "some value") == 0
	58	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	59	-Flags => DB_CREATE ;
	60
	61	# Add a few k/v pairs
	62	my $value ;
	63	my $status ;
	64	ok $db->db_put("some key", "some value") == 0
65	65	or diag "Cannot db_put: [$!][$BerkeleyDB::Error]\n" ;
66	66
67	67	ok $db->db_put("key", "value") == 0 ;

70	70	undef $db ;
71	71
72	72	# now open it with Unknown
73		ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	73	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
74	74
75	75	ok $db->type() == DB_HASH ;
76	76	ok $db->db_get("some key", $value) == 0 ;

94	94	my $lex = new LexFile $Dfile ;
95	95
96	96	# create a hash database
97		ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	97	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
98	98	-Flags => DB_CREATE ;
99	99
100	100	# Add a few k/v pairs

108	108
109	109	# now open it with Unknown
110	110	# create a hash database
111		ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	111	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
112	112
113	113	ok $db->type() == DB_BTREE ;
114	114	ok $db->db_get("some key", $value) == 0 ;

135	135	my $lex = new LexFile $Dfile ;
136	136
137	137	# create a recno database
138		ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	138	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
139	139	-Flags => DB_CREATE ;
140	140
141	141	# Add a few k/v pairs

149	149
150	150	# now open it with Unknown
151	151	# create a hash database
152		ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	152	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
153	153
154	154	ok $db->type() == DB_RECNO ;
155	155	ok $db->db_get(0, $value) == 0 ;

179	179	my $lex = new LexFile $Dfile ;
180	180
181	181	# create a hash database
182		ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
	182	ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
183	183	-Flags => DB_CREATE ;
184	184
185	185	# Add a few k/v pairs

195	195
196	196	# now open it with Unknown
197	197	# create a hash database
198		ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	198	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
199	199
200	200	ok $db->type() == DB_HEAP ;
201		ok $db->db_get($key1, $value) == 0
	201	ok $db->db_get($key1, $value) == 0
202	202	or diag "Cannot db_get: [$!][$BerkeleyDB::Error]\n" ;
203	203	ok $value eq "some value" ;
204	204	ok $db->db_get($key2, $value) == 0 ;

+9

-9

t/util.pm less more

32	32	{
33	33	sub try::TIEARRAY { bless [], "try" }
34	34	sub try::FETCHSIZE { $FA = 1 }
35		my @a ;
	35	my @a ;
36	36	tie @a, 'try' ;
37	37	my $a = @a ;
38	38	}

82	82	{
83	83	my $self = shift ;
84	84	my $dir = shift ;
85
	85
86	86	rmtree $dir if -e $dir ;
87
	87
88	88	mkdir $dir, 0777 or return undef ;
89	89
90	90	return bless [ $dir ], $self ;
91	91	}
92
93		sub DESTROY
	92
	93	sub DESTROY
94	94	{
95	95	my $self = shift ;
96	96	my $dir = $self->[0];

151	151	}
152	152
153	153	sub docat_del
154		{
	154	{
155	155	my $file = shift;
156	156	local $/ = undef;
157	157	open(CAT,$file) \|\| die "Cannot open $file: $!";

160	160	unlink $file ;
161	161	$result = normalise($result);
162	162	return $result;
163		}
	163	}
164	164
165	165	sub docat_del_sort
166		{
	166	{
167	167	my $file = shift;
168	168	open(CAT,$file) \|\| die "Cannot open $file: $!";
169	169	my @got = <CAT>;

174	174	unlink $file ;
175	175	$result = normalise($result);
176	176	return $result;
177		}
	177	}
178	178
179	179	sub readFile
180	180	{

+17

-17

typemap less more

0	0	# typemap for Perl 5 interface to Berkeley DB version 2 & 3
1	1	#
2		# SCCS: %I%, %G%
	2	# SCCS: %I%, %G%
3	3	#
4	4	# written by Paul Marquess <pmqs@cpan.org>
5	5	#
6	6	#################################### DB SECTION
7	7	#
8		#
	8	#
9	9
10	10	SVnull* T_SV_NULL
11	11	void * T_PV

174	174
175	175	T_IO_NULL
176	176	if ($arg == &PL_sv_undef)
177		$var = NULL ;
178		else
	177	$var = NULL ;
	178	else
179	179	$var = IoOFP(sv_2io($arg))
180	180
181	181	T_PTROBJ_NULL

216	216	DBT_clear($var) ;
217	217	SvGETMAGIC($arg) ;
218	218	if (db->recno_or_queue) {
219		Value = GetRecnoKey(db, SvIV(my_sv)) ;
220		$var.data = & Value;
	219	Value = GetRecnoKey(db, SvIV(my_sv)) ;
	220	$var.data = & Value;
221	221	$var.size = (int)sizeof(db_recno_t);
222	222	}
223	223	else {

250	250	SvGETMAGIC($arg) ;
251	251	if (db->recno_or_queue \|\|
252	252	(db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
253		Value = GetRecnoKey(db, SvIV(my_sv)) ;
254		$var.data = & Value;
	253	Value = GetRecnoKey(db, SvIV(my_sv)) ;
	254	$var.data = & Value;
255	255	$var.size = (int)sizeof(db_recno_t);
256	256	}
257	257	else {

291	291	DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
292	292	DBT_clear($var) ;
293	293	SvGETMAGIC($arg) ;
294		if (db->recno_or_queue \|\|
	294	if (db->recno_or_queue \|\|
295	295	(db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
296		Value = GetRecnoKey(db, SvIV(my_sv)) ;
297		$var.data = & Value;
	296	Value = GetRecnoKey(db, SvIV(my_sv)) ;
	297	$var.data = & Value;
298	298	$var.size = (int)sizeof(db_recno_t);
299	299	}
300	300	else {

312	312	DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
313	313	DBT_clear($var) ;
314	314	SvGETMAGIC($arg) ;
315		if (db->recno_or_queue \|\|
	315	if (db->recno_or_queue \|\|
316	316	(db->type == DB_BTREE && flagSet(DB_SET_RECNO))) {
317		Value = GetRecnoKey(db, SvIV(my_sv)) ;
318		$var.data = & Value;
	317	Value = GetRecnoKey(db, SvIV(my_sv)) ;
	318	$var.data = & Value;
319	319	$var.size = (int)sizeof(db_recno_t);
320	320	}
321	321	else {

343	343	$var.dlen = db->dlen ;
344	344	$var.doff = db->doff ;
345	345	}
346
	346
347	347	T_dbtdatum_opt
348	348	DBT_clear($var) ;
349	349	if (flagSetBoth()) {

357	357	$var.dlen = db->dlen ;
358	358	$var.doff = db->doff ;
359	359	}
360
	360
361	361	T_dbtdatum_btree
362	362	DBT_clear($var) ;
363	363	if (flagSetBoth()) {

371	371	$var.dlen = db->dlen ;
372	372	$var.doff = db->doff ;
373	373	}
374
	374
375	375
376	376	OUTPUT
377	377