Commit b9def6989544265d236458d5e9a40f28340d2c73 - libberkeleydb-perl

Imported Upstream version 0.38 Marco d'Itri 9 years ago

41 changed file(s) with 3409 addition(s) and 1734 deletion(s). Raw diff Collapse all Expand all

-2

BerkeleyDB.pm less more

1	1	package BerkeleyDB;
2	2
3	3
4		# Copyright (c) 1997-2008 Paul Marquess. All rights reserved.
	4	# Copyright (c) 1997-2009 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.34';
	19	$VERSION = '0.38';
20	20
21	21	require Exporter;
22	22	#require DynaLoader;

+434

-23

BerkeleyDB.pod less more

1369	1369
1370	1370	=back
1371	1371
	1372	The variant C<db_pget> allows you to query a secondary database:
	1373
	1374	$status = $sdb->db_pget($skey, $pkey, $value);
	1375
	1376	using the key C<$skey> in the secondary db to lookup C<$pkey> and C<$value>
	1377	from the primary db.
	1378
1372	1379
1373	1380	=head2 $status = $db->db_put($key, $value [, $flags])
1374	1381

1535	1542
1536	1543	=back
1537	1544
1538		You need to be running Berkeley DB 4.4 or better if you wan to make use of
	1545	You need to be running Berkeley DB 4.4 or better if you want to make use of
1539	1546	C<compact>.
	1547
	1548	=head2 $status = $db->associate($secondary, \&key_callback)
	1549
	1550	Associate C<$db> with the secondary DB C<$secondary>
	1551
	1552	New key/value pairs inserted to the database will be passed to the callback
	1553	which must set its third argument to the secondary key to allow lookup. If
	1554	an array reference is set multiple keys secondary keys will be associated
	1555	with the primary database entry.
	1556
	1557	Data may be retrieved fro the secondary database using C<db_pget> to also
	1558	obtain the primary key.
	1559
	1560	Secondary databased are maintained automatically.
1540	1561
1541	1562	=head1 CURSORS
1542	1563

1734	1755
1735	1756	=head2 $status = $cursor->c_pget() ;
1736	1757
	1758	See C<db_pget>
	1759
	1760	=head2 $status = $cursor->c_close()
	1761
	1762	Closes the cursor B<$cursor>.
	1763
	1764	=head2 Cursor Examples
	1765
1737	1766	TODO
1738	1767
1739		=head2 $status = $cursor->c_close()
1740
1741		Closes the cursor B<$cursor>.
1742
1743		=head2 Cursor Examples
	1768	Iterating from first to last, then in reverse.
	1769
	1770	examples of each of the flags.
	1771
	1772	=head1 JOIN
	1773
	1774	Join support for BerkeleyDB is in progress. Watch this space.
1744	1775
1745	1776	TODO
1746	1777
1747		Iterating from first to last, then in reverse.
1748
1749		examples of each of the flags.
1750
1751		=head1 JOIN
1752
1753		Join support for BerkeleyDB is in progress. Watch this space.
1754
1755		TODO
1756
1757	1778	=head1 TRANSACTIONS
1758	1779
1759		TODO.
1760
1761		=head1 CDS Mode
1762
1763		The Berkeley Db Concurrent Data Store is a lightweight locking mechanism
1764		that is useful in scenarios where transactions are overkill. See the
1765		accompanying document .. for details of using this module in CDS mode.
	1780	Transactions are created using the C<txn_begin> method on L<BerkeleyDB::Env>:
	1781
	1782	my $txn = $env->txn_begin;
	1783
	1784	If this is a nested transaction, supply the parent transaction as an
	1785	argument:
	1786
	1787	my $child_txn = $env->txn_begin($parent_txn);
	1788
	1789	Then in order to work with the transaction, you must set it as the current
	1790	transaction on the database handles you want to work with:
	1791
	1792	$db->Txn($txn);
	1793
	1794	Or for multiple handles:
	1795
	1796	$txn->Txn(@handles);
	1797
	1798	The current transaction is given by BerkeleyDB each time to the various BDB
	1799	operations. In the C api it is required explicitly as an argument to every
	1800	operation.
	1801
	1802	To commit a transaction call the C<commit> method on it:
	1803
	1804	$txn->commit;
	1805
	1806	and to roll back call abort:
	1807
	1808	$txn->abort
	1809
	1810	After committing or aborting a child transaction you need to set the active
	1811	transaction again using C<Txn>.
	1812
	1813
	1814	=head1 Berkeley DB Concurrent Data Store (CDS)
	1815
	1816	The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
	1817	mechanism that is useful in scenarios where transactions are overkill.
	1818
	1819	=head2 What is CDS?
	1820
	1821	The Berkeley DB CDS interface is a simple lightweight locking mechanism
	1822	that allows safe concurrent access to Berkeley DB databases. Your
	1823	application can have multiple reader and write processes, but Berkeley DB
	1824	will arrange it so that only one process can have a write lock against the
	1825	database at a time, i.e. multiple processes can read from a database
	1826	concurrently, but all write processes will be serialised.
	1827
	1828	=head2 Should I use it?
	1829
	1830	Whilst this simple locking model is perfectly adequate for some
	1831	applications, it will be too restrictive for others. Before deciding on
	1832	using CDS mode, you need to be sure that it is suitable for the expected
	1833	behaviour of your application.
	1834
	1835	The key features of this model are
	1836
	1837	=over 5
	1838
	1839	=item *
	1840
	1841	All writes operations are serialised.
	1842
	1843	=item *
	1844
	1845	A write operation will block until all reads have finished.
	1846
	1847	=back
	1848
	1849	There are a few of the attributes of your application that you need to be
	1850	aware of before choosing to use CDS.
	1851
	1852	Firstly, if you application needs either recoverability or transaction
	1853	support, then CDS will not be suitable.
	1854
	1855	Next what is the ratio of read operation to write operations will your
	1856	application have?
	1857
	1858	If it is carrying out mostly read operations, and very few writes, then CDS
	1859	may be appropriate.
	1860
	1861	What is the expected throughput of reads/writes in your application?
	1862
	1863	If you application does 90% writes and 10% reads, but on average you only
	1864	have a transaction every 5 seconds, then the fact that all writes are
	1865	serialised will not matter, because there will hardly ever be multiple
	1866	writes processes blocking.
	1867
	1868	In summary CDS mode may be appropriate for your application if it performs
	1869	mostly reads and very few writes or there is a low throughput. Also, if
	1870	you do not need to be able to roll back a series of database operations if
	1871	an error occurs, then CDS is ok.
	1872
	1873	If any of these is not the case you will need to use Berkeley DB
	1874	transactions. That is outside the scope of this document.
	1875
	1876	=head2 Locking Used
	1877
	1878	Berkeley DB implements CDS mode using two kinds of lock behind the scenes -
	1879	namely read locks and write locks. A read lock allows multiple processes to
	1880	access the database for reading at the same time. A write lock will only
	1881	get access to the database when there are no read or write locks active.
	1882	The write lock will block until the process holding the lock releases it.
	1883
	1884	Multiple processes with read locks can all access the database at the same
	1885	time as long as no process has a write lock. A process with a write lock
	1886	can only access the database if there are no other active read or write
	1887	locks.
	1888
	1889	The majority of the time the Berkeley DB CDS mode will handle all locking
	1890	without your application having to do anything. There are a couple of
	1891	exceptions you need to be aware of though - these will be discussed in
	1892	L<Safely Updating Records> and L<Implicit Cursors> below.
	1893
	1894	A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
	1895	lock on the database until it is either explicitly closed or destroyed.
	1896	This means the lock has the potential to be long lived.
	1897
	1898	By default Berkeley DB cursors create a read lock, but it is possible to
	1899	create a cursor that holds a write lock, thus
	1900
	1901	$cursor = $db->db_cursor(DB_WRITECURSOR);
	1902
	1903
	1904	Whilst either a read or write cursor is active, it will block any other
	1905	processes that wants to write to the database.
	1906
	1907	To avoid blocking problems, only keep cursors open as long as they are
	1908	needed. The same is true when you use the C<cursor> method or the
	1909	C<cds_lock> method.
	1910
	1911	For full information on CDS see the "Berkeley DB Concurrent Data Store
	1912	applications" section in the Berkeley DB Reference Guide.
	1913
	1914
	1915	=head2 Opening a database for CDS
	1916
	1917	Here is the typical signature that is used when opening a database in CDS
	1918	mode.
	1919
	1920	use BerkeleyDB ;
	1921
	1922	my $env = new BerkeleyDB::Env
	1923	-Home => "./home" ,
	1924	-Flags => DB_CREATE\| DB_INIT_CDB \| DB_INIT_MPOOL
	1925	or die "cannot open environment: $BerkeleyDB::Error\n";
	1926
	1927	my $db = new BerkeleyDB::Hash
	1928	-Filename => 'test1.db',
	1929	-Flags => DB_CREATE,
	1930	-Env => $env
	1931	or die "cannot open database: $BerkeleyDB::Error\n";
	1932
	1933	or this, if you use the tied interface
	1934
	1935	tie %hash, "BerkeleyDB::Hash",
	1936	-Filename => 'test2.db',
	1937	-Flags => DB_CREATE,
	1938	-Env => $env
	1939	or die "cannot open database: $BerkeleyDB::Error\n";
	1940
	1941	The first thing to note is that you B<MUST> always use a Berkeley DB
	1942	environment if you want to use locking with Berkeley DB.
	1943
	1944	Remember, that apart from the actual database files you explicitly create
	1945	yourself, Berkeley DB will create a few behind the scenes to handle locking
	1946	- they usually have names like "__db.001". It is therefore a good idea to
	1947	use the C<-Home> option, unless you are happy for all these files to be
	1948	written in the current directory.
	1949
	1950	Next, remember to include the C<DB_CREATE> flag when opening the
	1951	environment for the first time. A common mistake is to forget to add this
	1952	option and then wonder why the application doesn't work.
	1953
	1954	Finally, it is vital that all processes that are going to access the
	1955	database files use the same Berkeley DB environment.
	1956
	1957
	1958	=head2 Safely Updating a Record
	1959
	1960	One of the main gotchas when using CDS is if you want to update a record in
	1961	a database, i.e. you want to retrieve a record from a database, modify it
	1962	in some way and put it back in the database.
	1963
	1964	For example, say you are writing a web application and you want to keep a
	1965	record of the number of times your site is accessed in a Berkeley DB
	1966	database. So your code will have a line of code like this (assume, of
	1967	course, that C<%hash> has been tied to a Berkeley DB database):
	1968
	1969	$hash{Counter} ++ ;
	1970
	1971	That may look innocent enough, but there is a race condition lurking in
	1972	there. If I rewrite the line of code using the low-level Berkeley DB API,
	1973	which is what will actually be executed, the race condition may be more
	1974	apparent:
	1975
	1976	$db->db_get("Counter", $value);
	1977	++ $value ;
	1978	$db->db_put("Counter", $value);
	1979
	1980	Consider what happens behind the scenes when you execute the commands
	1981	above. Firstly, the existing value for the key "Counter" is fetched from
	1982	the database using C<db_get>. A read lock will be used for this part of the
	1983	update. The value is then incremented, and the new value is written back
	1984	to the database using C<db_put>. This time a write lock will be used.
	1985
	1986	Here's the problem - there is nothing to stop two (or more) processes
	1987	executing the read part at the same time. Remember multiple processes can
	1988	hold a read lock on the database at the same time. So both will fetch the
	1989	same value, let's say 7, from the database. Both increment the value to 8
	1990	and attempt to write it to the database. Berkeley DB will ensure that only
	1991	one of the processes gets a write lock, while the other will be blocked. So
	1992	the process that happened to get the write lock will store the value 8 to
	1993	the database and release the write lock. Now the other process will be
	1994	unblocked, and it too will write the value 8 to the database. The result,
	1995	in this example, is we have missed a hit in the counter.
	1996
	1997	To deal with this kind of scenario, you need to make the update atomic. A
	1998	convenience method, called C<cds_lock>, is supplied with the BerkeleyDB
	1999	module for this purpose. Using C<cds_lock>, the counter update code can now
	2000	be rewritten thus:
	2001
	2002	my $lk = $dbh->cds_lock() ;
	2003	$hash{Counter} ++ ;
	2004	$lk->cds_unlock;
	2005
	2006	or this, where scoping is used to limit the lifetime of the lock object
	2007
	2008	{
	2009	my $lk = $dbh->cds_lock() ;
	2010	$hash{Counter} ++ ;
	2011	}
	2012
	2013	Similarly, C<cds_lock> can be used with the native Berkeley DB API
	2014
	2015	my $lk = $dbh->cds_lock() ;
	2016	$db->db_get("Counter", $value);
	2017	++ $value ;
	2018	$db->db_put("Counter", $value);
	2019	$lk->unlock;
	2020
	2021
	2022	The C<cds_lock> method will ensure that the current process has exclusive
	2023	access to the database until the lock is either explicitly released, via
	2024	the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
	2025
	2026	If you are interested, all that C<cds_lock> does is open a "write" cursor.
	2027	This has the useful side-effect of holding a write-lock on the database
	2028	until the cursor is deleted. This is how you create a write-cursor
	2029
	2030	$cursor = $db->db_cursor(DB_WRITECURSOR);
	2031
	2032	If you have instantiated multiple C<cds_lock> objects for one database
	2033	within a single process, that process will hold a write-lock on the
	2034	database until I<ALL> C<cds_lock> objects have been destroyed.
	2035
	2036	As with all write-cursors, you should try to limit the scope of the
	2037	C<cds_lock> to as short a time as possible. Remember the complete database
	2038	will be locked to other process whilst the write lock is in place.
	2039
	2040	=head2 Cannot write with a read cursor while a write cursor is active
	2041
	2042	This issue is easier to demonstrate with an example, so consider the code
	2043	below. The intention of the code is to increment the values of all the
	2044	elements in a database by one.
	2045
	2046	# Assume $db is a database opened in a CDS environment.
	2047
	2048	# Create a write-lock
	2049	my $lock = $db->db_cursor(DB_WRITECURSOR);
	2050	# or
	2051	# my $lock = $db->cds_lock();
	2052
	2053
	2054	my $cursor = $db->db_cursor();
	2055
	2056	# Now loop through the database, and increment
	2057	# each value using c_put.
	2058	while ($cursor->c_get($key, $value, DB_NEXT) == 0)
	2059	{
	2060	$cursor->c_put($key, $value+1, DB_CURRENT) == 0
	2061	or die "$BerkeleyDB::Error\n";
	2062	}
	2063
	2064
	2065	When this code is run, it will fail on the C<c_put> line with this error
	2066
	2067	Write attempted on read-only cursor
	2068
	2069	The read cursor has automatically disallowed a write operation to prevent a
	2070	deadlock.
	2071
	2072
	2073	So the rule is -- you B<CANNOT> carry out a write operation using a
	2074	read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
	2075	write-cursor is already active.
	2076
	2077	The workaround for this issue is to just use C<db_put> instead of C<c_put>,
	2078	like this
	2079
	2080	# Assume $db is a database opened in a CDS environment.
	2081
	2082	# Create a write-lock
	2083	my $lock = $db->db_cursor(DB_WRITECURSOR);
	2084	# or
	2085	# my $lock = $db->cds_lock();
	2086
	2087
	2088	my $cursor = $db->db_cursor();
	2089
	2090	# Now loop through the database, and increment
	2091	# each value using c_put.
	2092	while ($cursor->c_get($key, $value, DB_NEXT) == 0)
	2093	{
	2094	$db->db_put($key, $value+1) == 0
	2095	or die "$BerkeleyDB::Error\n";
	2096	}
	2097
	2098
	2099
	2100	=head2 Implicit Cursors
	2101
	2102	All Berkeley DB cursors will hold either a read lock or a write lock on the
	2103	database for the existence of the cursor. In order to prevent blocking of
	2104	other processes you need to make sure that they are not long lived.
	2105
	2106	There are a number of instances where the Perl interface to Berkeley DB
	2107	will create a cursor behind the scenes without you being aware of it. Most
	2108	of these are very short-lived and will not affect the running of your
	2109	script, but there are a few notable exceptions.
	2110
	2111	Consider this snippet of code
	2112
	2113	while (my ($k, $v) = each %hash)
	2114	{
	2115	# do something
	2116	}
	2117
	2118
	2119	To implement the "each" functionality, a read cursor will be created behind
	2120	the scenes to allow you to iterate through the tied hash, C<%hash>. While
	2121	that cursor is still active, a read lock will obviously be held against the
	2122	database. If your application has any other writing processes, these will
	2123	be blocked until the read cursor is closed. That won't happen until the
	2124	loop terminates.
	2125
	2126	To avoid blocking problems, only keep cursors open as long as they are
	2127	needed. The same is true when you use the C<cursor> method or the
	2128	C<cds_lock> method.
	2129
	2130
	2131	The locking behaviour of the C<values> or C<keys> functions, shown below,
	2132	is subtly different.
	2133
	2134	foreach my $k (keys %hash)
	2135	{
	2136	# do something
	2137	}
	2138
	2139	foreach my $v (values %hash)
	2140	{
	2141	# do something
	2142	}
	2143
	2144
	2145	Just as in the C<each> function, a read cursor will be created to iterate
	2146	over the database in both of these cases. Where C<keys> and C<values>
	2147	differ is the place where the cursor carries out the iteration through the
	2148	database. Whilst C<each> carried out a single iteration every time it was
	2149	invoked, the C<keys> and C<values> functions will iterate through the
	2150	entire database in one go -- the complete database will be read into memory
	2151	before the first iteration of the loop.
	2152
	2153	Apart from the fact that a read lock will be held for the amount of time
	2154	required to iterate through the database, the use of C<keys> and C<values>
	2155	is B<not> recommended because it will result in the complete database being
	2156	read into memory.
	2157
	2158
	2159	=head2 Avoiding Deadlock with multiple databases
	2160
	2161	If your CDS application uses multiple database files, and you need to write
	2162	to more than one of them, you need to be careful you don't create a
	2163	deadlock.
	2164
	2165	For example, say you have two databases, D1 and D2, and two processes, P1
	2166	and P2. Assume you want to write a record to each database. If P1 writes
	2167	the records to the databases in the order D1, D2 while process P2 writes
	2168	the records in the order D2, D1, there is the potential for a deadlock to
	2169	occur.
	2170
	2171	This scenario can be avoided by either always acquiring the write locks in
	2172	exactly the same order in your application code, or by using the
	2173	C<DB_CDB_ALLDB> flag when opening the environment. This flag will make a
	2174	write-lock apply to all the databases in the environment.
	2175
	2176	Add example here
1766	2177
1767	2178	=head1 DBM Filters
1768	2179

+434

-23

BerkeleyDB.pod.P less more

1175	1175
1176	1176	=back
1177	1177
	1178	The variant C<db_pget> allows you to query a secondary database:
	1179
	1180	$status = $sdb->db_pget($skey, $pkey, $value);
	1181
	1182	using the key C<$skey> in the secondary db to lookup C<$pkey> and C<$value>
	1183	from the primary db.
	1184
1178	1185
1179	1186	=head2 $status = $db->db_put($key, $value [, $flags])
1180	1187

1341	1348
1342	1349	=back
1343	1350
1344		You need to be running Berkeley DB 4.4 or better if you wan to make use of
	1351	You need to be running Berkeley DB 4.4 or better if you want to make use of
1345	1352	C<compact>.
	1353
	1354	=head2 $status = $db->associate($secondary, \&key_callback)
	1355
	1356	Associate C<$db> with the secondary DB C<$secondary>
	1357
	1358	New key/value pairs inserted to the database will be passed to the callback
	1359	which must set its third argument to the secondary key to allow lookup. If
	1360	an array reference is set multiple keys secondary keys will be associated
	1361	with the primary database entry.
	1362
	1363	Data may be retrieved fro the secondary database using C<db_pget> to also
	1364	obtain the primary key.
	1365
	1366	Secondary databased are maintained automatically.
1346	1367
1347	1368	=head1 CURSORS
1348	1369

1540	1561
1541	1562	=head2 $status = $cursor->c_pget() ;
1542	1563
	1564	See C<db_pget>
	1565
	1566	=head2 $status = $cursor->c_close()
	1567
	1568	Closes the cursor B<$cursor>.
	1569
	1570	=head2 Cursor Examples
	1571
1543	1572	TODO
1544	1573
1545		=head2 $status = $cursor->c_close()
1546
1547		Closes the cursor B<$cursor>.
1548
1549		=head2 Cursor Examples
	1574	Iterating from first to last, then in reverse.
	1575
	1576	examples of each of the flags.
	1577
	1578	=head1 JOIN
	1579
	1580	Join support for BerkeleyDB is in progress. Watch this space.
1550	1581
1551	1582	TODO
1552	1583
1553		Iterating from first to last, then in reverse.
1554
1555		examples of each of the flags.
1556
1557		=head1 JOIN
1558
1559		Join support for BerkeleyDB is in progress. Watch this space.
1560
1561		TODO
1562
1563	1584	=head1 TRANSACTIONS
1564	1585
1565		TODO.
1566
1567		=head1 CDS Mode
1568
1569		The Berkeley Db Concurrent Data Store is a lightweight locking mechanism
1570		that is useful in scenarios where transactions are overkill. See the
1571		accompanying document .. for details of using this module in CDS mode.
	1586	Transactions are created using the C<txn_begin> method on L<BerkeleyDB::Env>:
	1587
	1588	my $txn = $env->txn_begin;
	1589
	1590	If this is a nested transaction, supply the parent transaction as an
	1591	argument:
	1592
	1593	my $child_txn = $env->txn_begin($parent_txn);
	1594
	1595	Then in order to work with the transaction, you must set it as the current
	1596	transaction on the database handles you want to work with:
	1597
	1598	$db->Txn($txn);
	1599
	1600	Or for multiple handles:
	1601
	1602	$txn->Txn(@handles);
	1603
	1604	The current transaction is given by BerkeleyDB each time to the various BDB
	1605	operations. In the C api it is required explicitly as an argument to every
	1606	operation.
	1607
	1608	To commit a transaction call the C<commit> method on it:
	1609
	1610	$txn->commit;
	1611
	1612	and to roll back call abort:
	1613
	1614	$txn->abort
	1615
	1616	After committing or aborting a child transaction you need to set the active
	1617	transaction again using C<Txn>.
	1618
	1619
	1620	=head1 Berkeley DB Concurrent Data Store (CDS)
	1621
	1622	The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
	1623	mechanism that is useful in scenarios where transactions are overkill.
	1624
	1625	=head2 What is CDS?
	1626
	1627	The Berkeley DB CDS interface is a simple lightweight locking mechanism
	1628	that allows safe concurrent access to Berkeley DB databases. Your
	1629	application can have multiple reader and write processes, but Berkeley DB
	1630	will arrange it so that only one process can have a write lock against the
	1631	database at a time, i.e. multiple processes can read from a database
	1632	concurrently, but all write processes will be serialised.
	1633
	1634	=head2 Should I use it?
	1635
	1636	Whilst this simple locking model is perfectly adequate for some
	1637	applications, it will be too restrictive for others. Before deciding on
	1638	using CDS mode, you need to be sure that it is suitable for the expected
	1639	behaviour of your application.
	1640
	1641	The key features of this model are
	1642
	1643	=over 5
	1644
	1645	=item *
	1646
	1647	All writes operations are serialised.
	1648
	1649	=item *
	1650
	1651	A write operation will block until all reads have finished.
	1652
	1653	=back
	1654
	1655	There are a few of the attributes of your application that you need to be
	1656	aware of before choosing to use CDS.
	1657
	1658	Firstly, if you application needs either recoverability or transaction
	1659	support, then CDS will not be suitable.
	1660
	1661	Next what is the ratio of read operation to write operations will your
	1662	application have?
	1663
	1664	If it is carrying out mostly read operations, and very few writes, then CDS
	1665	may be appropriate.
	1666
	1667	What is the expected throughput of reads/writes in your application?
	1668
	1669	If you application does 90% writes and 10% reads, but on average you only
	1670	have a transaction every 5 seconds, then the fact that all writes are
	1671	serialised will not matter, because there will hardly ever be multiple
	1672	writes processes blocking.
	1673
	1674	In summary CDS mode may be appropriate for your application if it performs
	1675	mostly reads and very few writes or there is a low throughput. Also, if
	1676	you do not need to be able to roll back a series of database operations if
	1677	an error occurs, then CDS is ok.
	1678
	1679	If any of these is not the case you will need to use Berkeley DB
	1680	transactions. That is outside the scope of this document.
	1681
	1682	=head2 Locking Used
	1683
	1684	Berkeley DB implements CDS mode using two kinds of lock behind the scenes -
	1685	namely read locks and write locks. A read lock allows multiple processes to
	1686	access the database for reading at the same time. A write lock will only
	1687	get access to the database when there are no read or write locks active.
	1688	The write lock will block until the process holding the lock releases it.
	1689
	1690	Multiple processes with read locks can all access the database at the same
	1691	time as long as no process has a write lock. A process with a write lock
	1692	can only access the database if there are no other active read or write
	1693	locks.
	1694
	1695	The majority of the time the Berkeley DB CDS mode will handle all locking
	1696	without your application having to do anything. There are a couple of
	1697	exceptions you need to be aware of though - these will be discussed in
	1698	L<Safely Updating Records> and L<Implicit Cursors> below.
	1699
	1700	A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
	1701	lock on the database until it is either explicitly closed or destroyed.
	1702	This means the lock has the potential to be long lived.
	1703
	1704	By default Berkeley DB cursors create a read lock, but it is possible to
	1705	create a cursor that holds a write lock, thus
	1706
	1707	$cursor = $db->db_cursor(DB_WRITECURSOR);
	1708
	1709
	1710	Whilst either a read or write cursor is active, it will block any other
	1711	processes that wants to write to the database.
	1712
	1713	To avoid blocking problems, only keep cursors open as long as they are
	1714	needed. The same is true when you use the C<cursor> method or the
	1715	C<cds_lock> method.
	1716
	1717	For full information on CDS see the "Berkeley DB Concurrent Data Store
	1718	applications" section in the Berkeley DB Reference Guide.
	1719
	1720
	1721	=head2 Opening a database for CDS
	1722
	1723	Here is the typical signature that is used when opening a database in CDS
	1724	mode.
	1725
	1726	use BerkeleyDB ;
	1727
	1728	my $env = new BerkeleyDB::Env
	1729	-Home => "./home" ,
	1730	-Flags => DB_CREATE\| DB_INIT_CDB \| DB_INIT_MPOOL
	1731	or die "cannot open environment: $BerkeleyDB::Error\n";
	1732
	1733	my $db = new BerkeleyDB::Hash
	1734	-Filename => 'test1.db',
	1735	-Flags => DB_CREATE,
	1736	-Env => $env
	1737	or die "cannot open database: $BerkeleyDB::Error\n";
	1738
	1739	or this, if you use the tied interface
	1740
	1741	tie %hash, "BerkeleyDB::Hash",
	1742	-Filename => 'test2.db',
	1743	-Flags => DB_CREATE,
	1744	-Env => $env
	1745	or die "cannot open database: $BerkeleyDB::Error\n";
	1746
	1747	The first thing to note is that you B<MUST> always use a Berkeley DB
	1748	environment if you want to use locking with Berkeley DB.
	1749
	1750	Remember, that apart from the actual database files you explicitly create
	1751	yourself, Berkeley DB will create a few behind the scenes to handle locking
	1752	- they usually have names like "__db.001". It is therefore a good idea to
	1753	use the C<-Home> option, unless you are happy for all these files to be
	1754	written in the current directory.
	1755
	1756	Next, remember to include the C<DB_CREATE> flag when opening the
	1757	environment for the first time. A common mistake is to forget to add this
	1758	option and then wonder why the application doesn't work.
	1759
	1760	Finally, it is vital that all processes that are going to access the
	1761	database files use the same Berkeley DB environment.
	1762
	1763
	1764	=head2 Safely Updating a Record
	1765
	1766	One of the main gotchas when using CDS is if you want to update a record in
	1767	a database, i.e. you want to retrieve a record from a database, modify it
	1768	in some way and put it back in the database.
	1769
	1770	For example, say you are writing a web application and you want to keep a
	1771	record of the number of times your site is accessed in a Berkeley DB
	1772	database. So your code will have a line of code like this (assume, of
	1773	course, that C<%hash> has been tied to a Berkeley DB database):
	1774
	1775	$hash{Counter} ++ ;
	1776
	1777	That may look innocent enough, but there is a race condition lurking in
	1778	there. If I rewrite the line of code using the low-level Berkeley DB API,
	1779	which is what will actually be executed, the race condition may be more
	1780	apparent:
	1781
	1782	$db->db_get("Counter", $value);
	1783	++ $value ;
	1784	$db->db_put("Counter", $value);
	1785
	1786	Consider what happens behind the scenes when you execute the commands
	1787	above. Firstly, the existing value for the key "Counter" is fetched from
	1788	the database using C<db_get>. A read lock will be used for this part of the
	1789	update. The value is then incremented, and the new value is written back
	1790	to the database using C<db_put>. This time a write lock will be used.
	1791
	1792	Here's the problem - there is nothing to stop two (or more) processes
	1793	executing the read part at the same time. Remember multiple processes can
	1794	hold a read lock on the database at the same time. So both will fetch the
	1795	same value, let's say 7, from the database. Both increment the value to 8
	1796	and attempt to write it to the database. Berkeley DB will ensure that only
	1797	one of the processes gets a write lock, while the other will be blocked. So
	1798	the process that happened to get the write lock will store the value 8 to
	1799	the database and release the write lock. Now the other process will be
	1800	unblocked, and it too will write the value 8 to the database. The result,
	1801	in this example, is we have missed a hit in the counter.
	1802
	1803	To deal with this kind of scenario, you need to make the update atomic. A
	1804	convenience method, called C<cds_lock>, is supplied with the BerkeleyDB
	1805	module for this purpose. Using C<cds_lock>, the counter update code can now
	1806	be rewritten thus:
	1807
	1808	my $lk = $dbh->cds_lock() ;
	1809	$hash{Counter} ++ ;
	1810	$lk->cds_unlock;
	1811
	1812	or this, where scoping is used to limit the lifetime of the lock object
	1813
	1814	{
	1815	my $lk = $dbh->cds_lock() ;
	1816	$hash{Counter} ++ ;
	1817	}
	1818
	1819	Similarly, C<cds_lock> can be used with the native Berkeley DB API
	1820
	1821	my $lk = $dbh->cds_lock() ;
	1822	$db->db_get("Counter", $value);
	1823	++ $value ;
	1824	$db->db_put("Counter", $value);
	1825	$lk->unlock;
	1826
	1827
	1828	The C<cds_lock> method will ensure that the current process has exclusive
	1829	access to the database until the lock is either explicitly released, via
	1830	the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
	1831
	1832	If you are interested, all that C<cds_lock> does is open a "write" cursor.
	1833	This has the useful side-effect of holding a write-lock on the database
	1834	until the cursor is deleted. This is how you create a write-cursor
	1835
	1836	$cursor = $db->db_cursor(DB_WRITECURSOR);
	1837
	1838	If you have instantiated multiple C<cds_lock> objects for one database
	1839	within a single process, that process will hold a write-lock on the
	1840	database until I<ALL> C<cds_lock> objects have been destroyed.
	1841
	1842	As with all write-cursors, you should try to limit the scope of the
	1843	C<cds_lock> to as short a time as possible. Remember the complete database
	1844	will be locked to other process whilst the write lock is in place.
	1845
	1846	=head2 Cannot write with a read cursor while a write cursor is active
	1847
	1848	This issue is easier to demonstrate with an example, so consider the code
	1849	below. The intention of the code is to increment the values of all the
	1850	elements in a database by one.
	1851
	1852	# Assume $db is a database opened in a CDS environment.
	1853
	1854	# Create a write-lock
	1855	my $lock = $db->db_cursor(DB_WRITECURSOR);
	1856	# or
	1857	# my $lock = $db->cds_lock();
	1858
	1859
	1860	my $cursor = $db->db_cursor();
	1861
	1862	# Now loop through the database, and increment
	1863	# each value using c_put.
	1864	while ($cursor->c_get($key, $value, DB_NEXT) == 0)
	1865	{
	1866	$cursor->c_put($key, $value+1, DB_CURRENT) == 0
	1867	or die "$BerkeleyDB::Error\n";
	1868	}
	1869
	1870
	1871	When this code is run, it will fail on the C<c_put> line with this error
	1872
	1873	Write attempted on read-only cursor
	1874
	1875	The read cursor has automatically disallowed a write operation to prevent a
	1876	deadlock.
	1877
	1878
	1879	So the rule is -- you B<CANNOT> carry out a write operation using a
	1880	read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
	1881	write-cursor is already active.
	1882
	1883	The workaround for this issue is to just use C<db_put> instead of C<c_put>,
	1884	like this
	1885
	1886	# Assume $db is a database opened in a CDS environment.
	1887
	1888	# Create a write-lock
	1889	my $lock = $db->db_cursor(DB_WRITECURSOR);
	1890	# or
	1891	# my $lock = $db->cds_lock();
	1892
	1893
	1894	my $cursor = $db->db_cursor();
	1895
	1896	# Now loop through the database, and increment
	1897	# each value using c_put.
	1898	while ($cursor->c_get($key, $value, DB_NEXT) == 0)
	1899	{
	1900	$db->db_put($key, $value+1) == 0
	1901	or die "$BerkeleyDB::Error\n";
	1902	}
	1903
	1904
	1905
	1906	=head2 Implicit Cursors
	1907
	1908	All Berkeley DB cursors will hold either a read lock or a write lock on the
	1909	database for the existence of the cursor. In order to prevent blocking of
	1910	other processes you need to make sure that they are not long lived.
	1911
	1912	There are a number of instances where the Perl interface to Berkeley DB
	1913	will create a cursor behind the scenes without you being aware of it. Most
	1914	of these are very short-lived and will not affect the running of your
	1915	script, but there are a few notable exceptions.
	1916
	1917	Consider this snippet of code
	1918
	1919	while (my ($k, $v) = each %hash)
	1920	{
	1921	# do something
	1922	}
	1923
	1924
	1925	To implement the "each" functionality, a read cursor will be created behind
	1926	the scenes to allow you to iterate through the tied hash, C<%hash>. While
	1927	that cursor is still active, a read lock will obviously be held against the
	1928	database. If your application has any other writing processes, these will
	1929	be blocked until the read cursor is closed. That won't happen until the
	1930	loop terminates.
	1931
	1932	To avoid blocking problems, only keep cursors open as long as they are
	1933	needed. The same is true when you use the C<cursor> method or the
	1934	C<cds_lock> method.
	1935
	1936
	1937	The locking behaviour of the C<values> or C<keys> functions, shown below,
	1938	is subtly different.
	1939
	1940	foreach my $k (keys %hash)
	1941	{
	1942	# do something
	1943	}
	1944
	1945	foreach my $v (values %hash)
	1946	{
	1947	# do something
	1948	}
	1949
	1950
	1951	Just as in the C<each> function, a read cursor will be created to iterate
	1952	over the database in both of these cases. Where C<keys> and C<values>
	1953	differ is the place where the cursor carries out the iteration through the
	1954	database. Whilst C<each> carried out a single iteration every time it was
	1955	invoked, the C<keys> and C<values> functions will iterate through the
	1956	entire database in one go -- the complete database will be read into memory
	1957	before the first iteration of the loop.
	1958
	1959	Apart from the fact that a read lock will be held for the amount of time
	1960	required to iterate through the database, the use of C<keys> and C<values>
	1961	is B<not> recommended because it will result in the complete database being
	1962	read into memory.
	1963
	1964
	1965	=head2 Avoiding Deadlock with multiple databases
	1966
	1967	If your CDS application uses multiple database files, and you need to write
	1968	to more than one of them, you need to be careful you don't create a
	1969	deadlock.
	1970
	1971	For example, say you have two databases, D1 and D2, and two processes, P1
	1972	and P2. Assume you want to write a record to each database. If P1 writes
	1973	the records to the databases in the order D1, D2 while process P2 writes
	1974	the records in the order D2, D1, there is the potential for a deadlock to
	1975	occur.
	1976
	1977	This scenario can be avoided by either always acquiring the write locks in
	1978	exactly the same order in your application code, or by using the
	1979	C<DB_CDB_ALLDB> flag when opening the environment. This flag will make a
	1980	write-lock apply to all the databases in the environment.
	1981
	1982	Add example here
1572	1983
1573	1984	=head1 DBM Filters
1574	1985

+412

-8

BerkeleyDB.xs less more

5	5
6	6	All comments/suggestions/problems are welcome
7	7
8		Copyright (c) 1997-2008 Paul Marquess. All rights reserved.
	8	Copyright (c) 1997-2009 Paul Marquess. All rights reserved.
9	9	This program is free software; you can redistribute it and/or
10	10	modify it under the same terms as Perl itself.
11	11

130	130
131	131	#if DB_VERSION_MAJOR > 4 \|\| (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 5)
132	132	# define AT_LEAST_DB_4_5
	133	#endif
	134
	135	#if DB_VERSION_MAJOR > 4 \|\| (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 6)
	136	# define AT_LEAST_DB_4_6
	137	#endif
	138
	139	#if DB_VERSION_MAJOR > 4 \|\| (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 7)
	140	# define AT_LEAST_DB_4_7
133	141	#endif
134	142
135	143	#ifdef __cplusplus

241	249	DBC * cursor ;
242	250	DB_TXN * txn ;
243	251	int open_cursors ;
	252	#ifdef AT_LEAST_DB_4_3
	253	int open_sequences ;
	254	#endif
244	255	u_int32_t partial ;
245	256	u_int32_t dlen ;
246	257	u_int32_t doff ;

308	319	#else
309	320	typedef DB_TXN BerkeleyDB_Txn_type ;
310	321	#endif
	322
	323	#ifdef AT_LEAST_DB_4_3
	324	typedef struct {
	325	int active;
	326	BerkeleyDB_type *db;
	327	DB_SEQUENCE *seq;
	328	} BerkeleyDB_Sequence_type;
	329	#else
	330	typedef int BerkeleyDB_Sequence_type;
	331	typedef SV* db_seq_t;
	332	#endif
	333
311	334
312	335	typedef BerkeleyDB_ENV_type * BerkeleyDB__Env ;
313	336	typedef BerkeleyDB_ENV_type * BerkeleyDB__Env__Raw ;

334	357	typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn ;
335	358	typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Raw ;
336	359	typedef BerkeleyDB_Txn_type * BerkeleyDB__Txn__Inner ;
	360	#ifdef AT_LEAST_DB_4_3
	361	typedef BerkeleyDB_Sequence_type * BerkeleyDB__Sequence ;
	362	#else
	363	typedef int * BerkeleyDB__Sequence ;
	364	#endif
337	365	#if 0
338	366	typedef DB_LOG * BerkeleyDB__Log ;
339	367	typedef DB_LOCKTAB * BerkeleyDB__Lock ;

344	372	typedef DBT DBTKEY_B ;
345	373	typedef DBT DBTKEY_Br ;
346	374	typedef DBT DBTKEY_Bpr ;
	375	typedef DBT DBTKEY_seq ;
347	376	typedef DBT DBTVALUE ;
348	377	typedef void * PV_or_NULL ;
349	378	typedef PerlIO * IO_or_NULL ;

470	499	} \
471	500	}
472	501
	502	#ifdef AT_LEAST_DB_4_3
	503
	504	#define InputKey_seq(arg, var) \
	505	{ \
	506	SV* my_sv = arg ; \
	507	/* DBM_ckFilter(my_sv, filter_store_key, "filter_store_key"); */ \
	508	DBT_clear(var) ; \
	509	SvGETMAGIC(arg) ; \
	510	if (seq->db->recno_or_queue) { \
	511	Value = GetRecnoKey(seq->db, SvIV(my_sv)) ; \
	512	var.data = & Value; \
	513	var.size = (int)sizeof(db_recno_t); \
	514	} \
	515	else { \
	516	STRLEN len; \
	517	var.data = SvPV(my_sv, len); \
	518	var.size = (int)len; \
	519	} \
	520	}
	521
	522	#define OutputKey_seq(arg, name) \
	523	{ if (RETVAL == 0) \
	524	{ \
	525	if (!seq->db->recno_or_queue) { \
	526	my_sv_setpvn(arg, name.data, name.size); \
	527	} \
	528	else \
	529	sv_setiv(arg, (I32)(I32)name.data - RECNO_BASE); \
	530	} \
	531	}
	532	#else
	533	#define InputKey_seq(arg, var)
	534	#define OutputKey_seq(arg, name)
	535	#endif
	536
473	537	#define OutputKey_B(arg, name) \
474	538	{ if (RETVAL == 0) \
475	539	{ \

531	595	#define ckActive_Transaction(a) ckActive(a, "Transaction")
532	596	#define ckActive_Database(a) ckActive(a, "Database")
533	597	#define ckActive_Cursor(a) ckActive(a, "Cursor")
	598	#ifdef AT_LEAST_DB_4_3
	599	#define ckActive_Sequence(a) ckActive(a, "Sequence")
	600	#else
	601	#define ckActive_Sequence(a)
	602	#endif
534	603
535	604	#define dieIfEnvOpened(e, m) if (e->opened) softCrash("Cannot call method BerkeleyDB::Env::%s after environment has been opened", m);
536	605

1170	1239	/* char sk_dat ; /
1171	1240	int retval ;
1172	1241	int count ;
	1242	int i ;
1173	1243	SV * skey_SV ;
1174	1244	STRLEN skey_len;
1175	1245	char * skey_ptr ;
	1246	AV * skey_AV;
	1247	DBT * tkey;
1176	1248
1177	1249	Trace(("In associate_cb \n")) ;
1178	1250	if (getCurrentDB->associated == NULL){

1223	1295	/* retrieve the secondary key */
1224	1296	DBT_clear(*skey);
1225	1297
1226		skey_ptr = SvPV(skey_SV, skey_len);
1227	1298	skey->flags = DB_DBT_APPMALLOC;
1228		/* skey->size = SvCUR(skey_SV); */
1229		/* skey->data = (char)safemalloc(skey->size); /
1230		skey->size = skey_len;
1231		skey->data = (char*)safemalloc(skey_len);
1232		memcpy(skey->data, skey_ptr, skey_len);
	1299
	1300	#ifdef AT_LEAST_DB_4_6
	1301	if ( SvROK(skey_SV) ) {
	1302	SV *rv = SvRV(skey_SV);
	1303
	1304	if ( SvTYPE(rv) == SVt_PVAV ) {
	1305	AV av = (AV )rv;
	1306	SV **svs = AvARRAY(av);
	1307	I32 len = av_len(av) + 1;
	1308	I32 i;
	1309	DBT *dbts;
	1310
	1311	if ( len == 0 ) {
	1312	retval = DB_DONOTINDEX;
	1313	} else if ( len == 1 ) {
	1314	skey_ptr = SvPV(svs[0], skey_len);
	1315	skey->size = skey_len;
	1316	skey->data = (char*)safemalloc(skey_len);
	1317	memcpy(skey->data, skey_ptr, skey_len);
	1318	Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));
	1319	} else {
	1320	skey->flags \|= DB_DBT_MULTIPLE ;
	1321
	1322	/* FIXME this will leak if safemalloc fails later... do we care? */
	1323	dbts = (DBT ) safemalloc(sizeof(DBT) len);
	1324	skey->size = len;
	1325	skey->data = (char *)dbts;
	1326
	1327	for ( i = 0; i < skey->size; i ++ ) {
	1328	skey_ptr = SvPV(svs[i], skey_len);
	1329
	1330	dbts[i].flags = DB_DBT_APPMALLOC;
	1331	dbts[i].size = skey_len;
	1332	dbts[i].data = (char *)safemalloc(skey_len);
	1333	memcpy(dbts[i].data, skey_ptr, skey_len);
	1334
	1335	Trace(("key is %d -- %.*s\n", dbts[i].size, dbts[i].size, dbts[i].data));
	1336	}
	1337	Trace(("mkey has %d subkeys\n", skey->size));
	1338	}
	1339	} else {
	1340	croak("Not an array reference");
	1341	}
	1342	} else
	1343	#endif
	1344	{
	1345	skey_ptr = SvPV(skey_SV, skey_len);
	1346	/* skey->size = SvCUR(skey_SV); */
	1347	/* skey->data = (char)safemalloc(skey->size); /
	1348	skey->size = skey_len;
	1349	skey->data = (char*)safemalloc(skey_len);
	1350	memcpy(skey->data, skey_ptr, skey_len);
	1351	}
1233	1352	Trace(("key is %d -- %.*s\n", skey->size, skey->size, skey->data));
1234	1353
1235	1354	FREETMPS ;

2252	2371	#endif
2253	2372	}
2254	2373
	2374	DualType
	2375	log_set_config(env, flags=0, onoff=0)
	2376	BerkeleyDB::Env env
	2377	u_int32_t flags
	2378	int onoff
	2379	PREINIT:
	2380	dMY_CXT;
	2381	CODE:
	2382	{
	2383	#ifndef AT_LEAST_DB_4_7
	2384	softCrash("log_set_config needs at least Berkeley DB 4.7.x");
	2385	#else
	2386	RETVAL = env->Status = env->Env->log_set_config(env->Env, flags, onoff) ;
	2387	#endif
	2388	}
	2389	OUTPUT:
	2390	RETVAL
	2391
	2392	DualType
	2393	log_get_config(env, flags, onoff)
	2394	BerkeleyDB::Env env
	2395	u_int32_t flags
	2396	int onoff=NO_INIT
	2397	PREINIT:
	2398	dMY_CXT;
	2399	CODE:
	2400	{
	2401	#ifndef AT_LEAST_DB_4_7
	2402	softCrash("log_get_config needs at least Berkeley DB 4.7.x");
	2403	#else
	2404	RETVAL = env->Status = env->Env->log_get_config(env->Env, flags, &onoff) ;
	2405	#endif
	2406	}
	2407	OUTPUT:
	2408	RETVAL
	2409	onoff
	2410
	2411
2255	2412	BerkeleyDB::Txn::Raw
2256	2413	_txn_begin(env, pid=NULL, flags=0)
2257	2414	u_int32_t flags

3337	3494	if (db->open_cursors)
3338	3495	softCrash("attempted to close a database with %d open cursor(s)",
3339	3496	db->open_cursors) ;
	3497	#ifdef AT_LEAST_DB_4_3
	3498	if (db->open_sequences)
	3499	softCrash("attempted to close a database with %d open sequence(s)",
	3500	db->open_sequences) ;
	3501	#endif /* AT_LEAST_DB_4_3 */
3340	3502	#endif /* STRICT_CLOSE */
3341	3503	RETVAL = db->Status = ((db->dbp)->close)(db->dbp, flags) ;
3342	3504	if (db->parent_env && db->parent_env->open_dbs)

3873	4035
3874	4036	#ifdef AT_LEAST_DB_4_1
3875	4037	# define db_associate(db, sec, cb, flags)\
3876		(db->Status = ((db->dbp)->associate)(db->dbp, NULL, sec->dbp, &cb, flags))
	4038	(db->Status = ((db->dbp)->associate)(db->dbp, db->txn, sec->dbp, &cb, flags))
3877	4039	#else
3878	4040	# define db_associate(db, sec, cb, flags)\
3879	4041	(db->Status = ((db->dbp)->associate)(db->dbp, sec->dbp, &cb, flags))

4586	4748	OUTPUT:
4587	4749	RETVAL
4588	4750
	4751
	4752	MODULE = BerkeleyDB::Common PACKAGE = BerkeleyDB::Common
	4753
	4754	BerkeleyDB::Sequence
	4755	db_create_sequence(db, flags=0)
	4756	BerkeleyDB::Common db
	4757	u_int32_t flags
	4758	PREINIT:
	4759	dMY_CXT;
	4760	CODE:
	4761	{
	4762	#ifndef AT_LEAST_DB_4_3
	4763	softCrash("$seq->create_sequence needs Berkeley DB 4.3.x or better") ;
	4764	#else
	4765	DB_SEQUENCE * seq ;
	4766	saveCurrentDB(db);
	4767	RETVAL = NULL;
	4768	if (db_sequence_create(&seq, db->dbp, flags) == 0)
	4769	{
	4770	ZMALLOC(RETVAL, BerkeleyDB_Sequence_type);
	4771	RETVAL->db = db;
	4772	RETVAL->seq = seq;
	4773	RETVAL->active = TRUE;
	4774	++ db->open_sequences ;
	4775	}
	4776	#endif
	4777	}
	4778	OUTPUT:
	4779	RETVAL
	4780
	4781
	4782	MODULE = BerkeleyDB::Sequence PACKAGE = BerkeleyDB::Sequence PREFIX = seq_
	4783
	4784	DualType
	4785	open(seq, key, flags=0)
	4786	BerkeleyDB::Sequence seq
	4787	DBTKEY_seq key
	4788	u_int32_t flags
	4789	PREINIT:
	4790	dMY_CXT;
	4791	INIT:
	4792	ckActive_Sequence(seq->active) ;
	4793	CODE:
	4794	#ifndef AT_LEAST_DB_4_3
	4795	softCrash("$seq->create_sequence needs Berkeley DB 4.3.x or better") ;
	4796	#else
	4797	RETVAL = seq->seq->open(seq->seq, seq->db->txn, &key, flags);
	4798	#endif
	4799	OUTPUT:
	4800	RETVAL
	4801
	4802	DualType
	4803	close(seq,flags=0)
	4804	BerkeleyDB::Sequence seq;
	4805	u_int32_t flags;
	4806	PREINIT:
	4807	dMY_CXT;
	4808	INIT:
	4809	ckActive_Sequence(seq->active) ;
	4810	CODE:
	4811	#ifndef AT_LEAST_DB_4_3
	4812	softCrash("$seq->close needs Berkeley DB 4.3.x or better") ;
	4813	#else
	4814	RETVAL = 0;
	4815	if (seq->active) {
	4816	-- seq->db->open_sequences;
	4817	RETVAL = seq->seq->close(seq->seq, flags);
	4818	}
	4819	seq->active = FALSE;
	4820	#endif
	4821	OUTPUT:
	4822	RETVAL
	4823
	4824	DualType
	4825	remove(seq,flags=0)
	4826	BerkeleyDB::Sequence seq;
	4827	u_int32_t flags;
	4828	PREINIT:
	4829	dMY_CXT;
	4830	INIT:
	4831	ckActive_Sequence(seq->active) ;
	4832	CODE:
	4833	#ifndef AT_LEAST_DB_4_3
	4834	softCrash("$seq->remove needs Berkeley DB 4.3.x or better") ;
	4835	#else
	4836	RETVAL = 0;
	4837	if (seq->active)
	4838	RETVAL = seq->seq->remove(seq->seq, seq->db->txn, flags);
	4839	seq->active = FALSE;
	4840	#endif
	4841	OUTPUT:
	4842	RETVAL
	4843
	4844	void
	4845	DESTROY(seq)
	4846	BerkeleyDB::Sequence seq
	4847	PREINIT:
	4848	dMY_CXT;
	4849	CODE:
	4850	#ifdef AT_LEAST_DB_4_3
	4851	if (seq->active)
	4852	seq->seq->close(seq->seq, 0);
	4853	Safefree(seq);
	4854	#endif
	4855
	4856	DualType
	4857	get(seq, element, delta=1, flags=0)
	4858	BerkeleyDB::Sequence seq;
	4859	IV delta;
	4860	db_seq_t element = NO_INIT
	4861	u_int32_t flags;
	4862	PREINIT:
	4863	dMY_CXT;
	4864	INIT:
	4865	ckActive_Sequence(seq->active) ;
	4866	CODE:
	4867	#ifndef AT_LEAST_DB_4_3
	4868	softCrash("$seq->get needs Berkeley DB 4.3.x or better") ;
	4869	#else
	4870	RETVAL = seq->seq->get(seq->seq, seq->db->txn, delta, &element, flags);
	4871	#endif
	4872	OUTPUT:
	4873	RETVAL
	4874	element
	4875
	4876	DualType
	4877	get_key(seq, key)
	4878	BerkeleyDB::Sequence seq;
	4879	DBTKEY_seq key = NO_INIT
	4880	PREINIT:
	4881	dMY_CXT;
	4882	INIT:
	4883	ckActive_Sequence(seq->active) ;
	4884	CODE:
	4885	#ifndef AT_LEAST_DB_4_3
	4886	softCrash("$seq->get_key needs Berkeley DB 4.3.x or better") ;
	4887	#else
	4888	DBT_clear(key);
	4889	RETVAL = seq->seq->get_key(seq->seq, &key);
	4890	#endif
	4891	OUTPUT:
	4892	RETVAL
	4893	key
	4894
	4895	DualType
	4896	initial_value(seq, low, high=0)
	4897	BerkeleyDB::Sequence seq;
	4898	int low
	4899	int high
	4900	PREINIT:
	4901	dMY_CXT;
	4902	INIT:
	4903	ckActive_Sequence(seq->active) ;
	4904	CODE:
	4905	#ifndef AT_LEAST_DB_4_3
	4906	softCrash("$seq->initial_value needs Berkeley DB 4.3.x or better") ;
	4907	#else
	4908	RETVAL = seq->seq->initial_value(seq->seq, (db_seq_t)(high << 32 + low));
	4909	#endif
	4910	OUTPUT:
	4911	RETVAL
	4912
	4913	DualType
	4914	set_cachesize(seq, size)
	4915	BerkeleyDB::Sequence seq;
	4916	int32_t size
	4917	PREINIT:
	4918	dMY_CXT;
	4919	INIT:
	4920	ckActive_Sequence(seq->active) ;
	4921	CODE:
	4922	#ifndef AT_LEAST_DB_4_3
	4923	softCrash("$seq->set_cachesize needs Berkeley DB 4.3.x or better") ;
	4924	#else
	4925	RETVAL = seq->seq->set_cachesize(seq->seq, size);
	4926	#endif
	4927	OUTPUT:
	4928	RETVAL
	4929
	4930	DualType
	4931	get_cachesize(seq, size)
	4932	BerkeleyDB::Sequence seq;
	4933	int32_t size = NO_INIT
	4934	PREINIT:
	4935	dMY_CXT;
	4936	INIT:
	4937	ckActive_Sequence(seq->active) ;
	4938	CODE:
	4939	#ifndef AT_LEAST_DB_4_3
	4940	softCrash("$seq->get_cachesize needs Berkeley DB 4.3.x or better") ;
	4941	#else
	4942	RETVAL = seq->seq->get_cachesize(seq->seq, &size);
	4943	#endif
	4944	OUTPUT:
	4945	RETVAL
	4946	size
	4947
	4948	DualType
	4949	set_flags(seq, flags)
	4950	BerkeleyDB::Sequence seq;
	4951	u_int32_t flags
	4952	PREINIT:
	4953	dMY_CXT;
	4954	INIT:
	4955	ckActive_Sequence(seq->active) ;
	4956	CODE:
	4957	#ifndef AT_LEAST_DB_4_3
	4958	softCrash("$seq->set_flags needs Berkeley DB 4.3.x or better") ;
	4959	#else
	4960	RETVAL = seq->seq->set_flags(seq->seq, flags);
	4961	#endif
	4962	OUTPUT:
	4963	RETVAL
	4964
	4965	DualType
	4966	get_flags(seq, flags)
	4967	BerkeleyDB::Sequence seq;
	4968	u_int32_t flags = NO_INIT
	4969	PREINIT:
	4970	dMY_CXT;
	4971	INIT:
	4972	ckActive_Sequence(seq->active) ;
	4973	CODE:
	4974	#ifndef AT_LEAST_DB_4_3
	4975	softCrash("$seq->get_flags needs Berkeley DB 4.3.x or better") ;
	4976	#else
	4977	RETVAL = seq->seq->get_flags(seq->seq, &flags);
	4978	#endif
	4979	OUTPUT:
	4980	RETVAL
	4981	flags
	4982
	4983	DualType
	4984	set_range(seq)
	4985	BerkeleyDB::Sequence seq;
	4986	NOT_IMPLEMENTED_YET
	4987
	4988	DualType
	4989	stat(seq)
	4990	BerkeleyDB::Sequence seq;
	4991	NOT_IMPLEMENTED_YET
	4992
4589	4993
4590	4994	MODULE = BerkeleyDB PACKAGE = BerkeleyDB
4591	4995

+28

-0

Changes less more

0	0	Revision history for Perl extension BerkeleyDB.
	1
	2	0.38 21st February 2009
	3
	4	* Fixed typo in BerkleyDB.pod that broke t/pod.t
	5
	6	0.37 18th February 2009
	7
	8	* Included CDS section to the pod.
	9
	10	* Various documentation patches from RT#42243
	11
	12	0.36 30th September 2008
	13
	14	* Added support for $ENV->log_get_config and $ENV->log_set_config.
	15	Patch supplied by Yuval Kogman (#39651 rt.cpan.org)
	16
	17	0.35 22nd September 2008
	18
	19	* Added a combination of independent patches from Claes Jakobsson
	20	and Yuval Kogman (#38896 rt.cpan.org) to allow multi-key return
	21	from a secondard database.
	22
	23	* Added support for sequences. Initial patch from Claes Jakobsson.
	24
	25	* Get associate to use a transaction if one is specified.
	26	#5855 from rt.cpan.org
	27
	28	* Finish transition of test harness to use Test::More
1	29
2	30	0.34 27th March 2008
3	31

-0

MANIFEST less more

25	25	t/db-3.3.t
26	26	t/db-4.x.t
27	27	t/db-4.4.t
	28	t/db-4.6.t
	29	t/db-4.7.t
28	30	t/destroy.t
29	31	t/encrypt.t
30	32	t/env.t

39	41	t/pod.t
40	42	t/queue.t
41	43	t/recno.t
	44	t/sequence.t
42	45	t/strict.t
43	46	t/subdb.t
44	47	t/txn.t

-2

META.yml less more

0	0	--- #YAML:1.0
1	1	name: BerkeleyDB
2		version: 0.34
	2	version: 0.38
3	3	abstract: Perl extension for Berkeley DB version 2, 3 or 4
4	4	license: perl
5	5	author:
6	6	- Paul Marquess <pmqs@cpan.org>
7		generated_by: ExtUtils::MakeMaker version 6.44
	7	generated_by: ExtUtils::MakeMaker version 6.42
8	8	distribution_type: module
9	9	requires:
10	10	meta-spec:

-5

README less more

0	0	BerkeleyDB
1	1
2		Version 0.34
3
4		27th March 2008
5
6		Copyright (c) 1997-2008 Paul Marquess. All rights reserved. This
	2	Version 0.38
	3
	4	21st February 2009
	5
	6
	7	Copyright (c) 1997-2009 Paul Marquess. All rights reserved. This
7	8	program is free software; you can redistribute it and/or modify
8	9	it under the same terms as Perl itself.
9	10

-1

dbinfo less more

4	4	#
5	5	# Author: Paul Marquess <Paul.Marquess@btinternet.com>
6	6	# Version: 1.06
7		# Date 27th MArch 2008
	7	# Date 27th March 2008
8	8	#
9	9	# Copyright (c) 1998-2008 Paul Marquess. All rights reserved.
10	10	# This program is free software; you can redistribute it and/or

+178

-144

t/Test/Builder.pm less more

7	7
8	8	use strict;
9	9	use vars qw($VERSION);
10		$VERSION = '0.22';
	10	$VERSION = '0.30';
11	11	$VERSION = eval $VERSION; # make the alpha version come out as a number
12	12
13	13	# Make Test::Builder thread-safe for ithreads.

114	114	Returns a Test::Builder object representing the current state of the
115	115	test.
116	116
117		Since you only run one test per program, there is B<one and only one>
	117	Since you only run one test per program C<new> always returns the same
118	118	Test::Builder object. No matter how many times you call new(), you're
119		getting the same object. (This is called a singleton).
	119	getting the same object. This is called a singleton. This is done so that
	120	multiple modules share such global information as the test counter and
	121	where test output is going.
	122
	123	If you want a completely new Test::Builder object different from the
	124	singleton, use C<create>.
120	125
121	126	=cut
122	127
123	128	my $Test = Test::Builder->new;
124	129	sub new {
125	130	my($class) = shift;
126		$Test \|\|= bless ['Move along, nothing to see here'], $class;
	131	$Test \|\|= $class->create;
127	132	return $Test;
	133	}
	134
	135
	136	=item B<create>
	137
	138	my $Test = Test::Builder->create;
	139
	140	Ok, so there can be more than one Test::Builder object and this is how
	141	you get it. You might use this instead of C<new()> if you're testing
	142	a Test::Builder based module, but otherwise you probably want C<new>.
	143
	144	B<NOTE>: the implementation is not complete. C<level>, for example, is
	145	still shared amongst B<all> Test::Builder objects, even ones created using
	146	this method. Also, the method name may change in the future.
	147
	148	=cut
	149
	150	sub create {
	151	my $class = shift;
	152
	153	my $self = bless {}, $class;
	154	$self->reset;
	155
	156	return $self;
128	157	}
129	158
130	159	=item B<reset>

137	166
138	167	=cut
139	168
140		my $Test_Died;
141		my $Have_Plan;
142		my $No_Plan;
143		my $Curr_Test; share($Curr_Test);
144	169	use vars qw($Level);
145		my $Original_Pid;
146		my @Test_Results; share(@Test_Results);
147
148		my $Exported_To;
149		my $Expected_Tests;
150
151		my $Skip_All;
152
153		my $Use_Nums;
154
155		my($No_Header, $No_Ending);
156
157		$Test->reset;
158	170
159	171	sub reset {
160	172	my ($self) = @_;
161	173
162		$Test_Died = 0;
163		$Have_Plan = 0;
164		$No_Plan = 0;
165		$Curr_Test = 0;
166		$Level = 1;
167		$Original_Pid = $$;
168		@Test_Results = ();
169
170		$Exported_To = undef;
171		$Expected_Tests = 0;
172
173		$Skip_All = 0;
174
175		$Use_Nums = 1;
176
177		($No_Header, $No_Ending) = (0,0);
	174	# We leave this a global because it has to be localized and localizing
	175	# hash keys is just asking for pain. Also, it was documented.
	176	$Level = 1;
	177
	178	$self->{Test_Died} = 0;
	179	$self->{Have_Plan} = 0;
	180	$self->{No_Plan} = 0;
	181	$self->{Original_Pid} = $$;
	182
	183	share($self->{Curr_Test});
	184	$self->{Curr_Test} = 0;
	185	$self->{Test_Results} = &share([]);
	186
	187	$self->{Exported_To} = undef;
	188	$self->{Expected_Tests} = 0;
	189
	190	$self->{Skip_All} = 0;
	191
	192	$self->{Use_Nums} = 1;
	193
	194	$self->{No_Header} = 0;
	195	$self->{No_Ending} = 0;
178	196
179	197	$self->_dup_stdhandles unless $^C;
180	198

204	222	my($self, $pack) = @_;
205	223
206	224	if( defined $pack ) {
207		$Exported_To = $pack;
208		}
209		return $Exported_To;
	225	$self->{Exported_To} = $pack;
	226	}
	227	return $self->{Exported_To};
210	228	}
211	229
212	230	=item B<plan>

227	245
228	246	return unless $cmd;
229	247
230		if( $Have_Plan ) {
	248	if( $self->{Have_Plan} ) {
231	249	die sprintf "You tried to plan twice! Second plan at %s line %d\n",
232	250	($self->caller)[1,2];
233	251	}

277	295	die "Number of tests must be a postive integer. You gave it '$max'.\n"
278	296	unless $max =~ /^\+?\d+$/ and $max > 0;
279	297
280		$Expected_Tests = $max;
281		$Have_Plan = 1;
	298	$self->{Expected_Tests} = $max;
	299	$self->{Have_Plan} = 1;
282	300
283	301	$self->_print("1..$max\n") unless $self->no_header;
284	302	}
285		return $Expected_Tests;
	303	return $self->{Expected_Tests};
286	304	}
287	305
288	306

295	313	=cut
296	314
297	315	sub no_plan {
298		$No_Plan = 1;
299		$Have_Plan = 1;
	316	my $self = shift;
	317
	318	$self->{No_Plan} = 1;
	319	$self->{Have_Plan} = 1;
300	320	}
301	321
302	322	=item B<has_plan>
303	323
304	324	$plan = $Test->has_plan
305
	325
306	326	Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
307	327
308	328	=cut
309	329
310	330	sub has_plan {
311		return($Expected_Tests) if $Expected_Tests;
312		return('no_plan') if $No_Plan;
313		return(undef);
	331	my $self = shift;
	332
	333	return($self->{Expected_Tests}) if $self->{Expected_Tests};
	334	return('no_plan') if $self->{No_Plan};
	335	return(undef);
314	336	};
315	337
316	338

330	352	$out .= " # Skip $reason" if $reason;
331	353	$out .= "\n";
332	354
333		$Skip_All = 1;
	355	$self->{Skip_All} = 1;
334	356
335	357	$self->_print($out) unless $self->no_header;
336	358	exit(0);

363	385	# store, so we turn it into a boolean.
364	386	$test = $test ? 1 : 0;
365	387
366		unless( $Have_Plan ) {
	388	unless( $self->{Have_Plan} ) {
367	389	require Carp;
368	390	Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
369	391	}
370	392
371		lock $Curr_Test;
372		$Curr_Test++;
	393	lock $self->{Curr_Test};
	394	$self->{Curr_Test}++;
373	395
374	396	# In case $name is a string overloaded object, force it to stringify.
375	397	$self->_unoverload(\$name);

396	418	}
397	419
398	420	$out .= "ok";
399		$out .= " $Curr_Test" if $self->use_numbers;
	421	$out .= " $self->{Curr_Test}" if $self->use_numbers;
400	422
401	423	if( defined $name ) {
402	424	$name =~ s\|#\|\\#\|g; # # in a name can confuse Test::Harness.

417	439	$result->{type} = '';
418	440	}
419	441
420		$Test_Results[$Curr_Test-1] = $result;
	442	$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
421	443	$out .= "\n";
422	444
423	445	$self->_print($out);

770	792	$why \|\|= '';
771	793	$self->_unoverload(\$why);
772	794
773		unless( $Have_Plan ) {
	795	unless( $self->{Have_Plan} ) {
774	796	require Carp;
775	797	Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
776	798	}
777	799
778		lock($Curr_Test);
779		$Curr_Test++;
780
781		$Test_Results[$Curr_Test-1] = &share({
	800	lock($self->{Curr_Test});
	801	$self->{Curr_Test}++;
	802
	803	$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
782	804	'ok' => 1,
783	805	actual_ok => 1,
784	806	name => '',

787	809	});
788	810
789	811	my $out = "ok";
790		$out .= " $Curr_Test" if $self->use_numbers;
	812	$out .= " $self->{Curr_Test}" if $self->use_numbers;
791	813	$out .= " # skip";
792	814	$out .= " $why" if length $why;
793	815	$out .= "\n";
794	816
795		$Test->_print($out);
	817	$self->_print($out);
796	818
797	819	return 1;
798	820	}

814	836	my($self, $why) = @_;
815	837	$why \|\|= '';
816	838
817		unless( $Have_Plan ) {
	839	unless( $self->{Have_Plan} ) {
818	840	require Carp;
819	841	Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
820	842	}
821	843
822		lock($Curr_Test);
823		$Curr_Test++;
824
825		$Test_Results[$Curr_Test-1] = &share({
	844	lock($self->{Curr_Test});
	845	$self->{Curr_Test}++;
	846
	847	$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
826	848	'ok' => 1,
827	849	actual_ok => 0,
828	850	name => '',

831	853	});
832	854
833	855	my $out = "not ok";
834		$out .= " $Curr_Test" if $self->use_numbers;
	856	$out .= " $self->{Curr_Test}" if $self->use_numbers;
835	857	$out .= " # TODO & SKIP $why\n";
836	858
837		$Test->_print($out);
	859	$self->_print($out);
838	860
839	861	return 1;
840	862	}

920	942	my($self, $use_nums) = @_;
921	943
922	944	if( defined $use_nums ) {
923		$Use_Nums = $use_nums;
924		}
925		return $Use_Nums;
	945	$self->{Use_Nums} = $use_nums;
	946	}
	947	return $self->{Use_Nums};
926	948	}
927	949
928	950	=item B<no_header>

946	968	my($self, $no_header) = @_;
947	969
948	970	if( defined $no_header ) {
949		$No_Header = $no_header;
950		}
951		return $No_Header;
	971	$self->{No_Header} = $no_header;
	972	}
	973	return $self->{No_Header};
952	974	}
953	975
954	976	sub no_ending {
955	977	my($self, $no_ending) = @_;
956	978
957	979	if( defined $no_ending ) {
958		$No_Ending = $no_ending;
959		}
960		return $No_Ending;
	980	$self->{No_Ending} = $no_ending;
	981	}
	982	return $self->{No_Ending};
961	983	}
962	984
963	985

1101	1123
1102	1124	=cut
1103	1125
1104		my($Out_FH, $Fail_FH, $Todo_FH);
1105	1126	sub output {
1106	1127	my($self, $fh) = @_;
1107	1128
1108	1129	if( defined $fh ) {
1109		$Out_FH = _new_fh($fh);
1110		}
1111		return $Out_FH;
	1130	$self->{Out_FH} = _new_fh($fh);
	1131	}
	1132	return $self->{Out_FH};
1112	1133	}
1113	1134
1114	1135	sub failure_output {
1115	1136	my($self, $fh) = @_;
1116	1137
1117	1138	if( defined $fh ) {
1118		$Fail_FH = _new_fh($fh);
1119		}
1120		return $Fail_FH;
	1139	$self->{Fail_FH} = _new_fh($fh);
	1140	}
	1141	return $self->{Fail_FH};
1121	1142	}
1122	1143
1123	1144	sub todo_output {
1124	1145	my($self, $fh) = @_;
1125	1146
1126	1147	if( defined $fh ) {
1127		$Todo_FH = _new_fh($fh);
1128		}
1129		return $Todo_FH;
	1148	$self->{Todo_FH} = _new_fh($fh);
	1149	}
	1150	return $self->{Todo_FH};
1130	1151	}
1131	1152
1132	1153

1141	1162	$fh = do { local *FH };
1142	1163	open $fh, ">$file_or_fh" or
1143	1164	die "Can't open test output log $file_or_fh: $!";
	1165	_autoflush($fh);
1144	1166	}
1145	1167
1146	1168	return $fh;

1168	1190	}
1169	1191
1170	1192
1171		my $Opened_Testhandles = 0;
1172	1193	sub _dup_stdhandles {
1173	1194	my $self = shift;
1174	1195
1175		$self->_open_testhandles unless $Opened_Testhandles;
	1196	$self->_open_testhandles;
1176	1197
1177	1198	# Set everything to unbuffered else plain prints to STDOUT will
1178	1199	# come out in the wrong order from our own prints.

1181	1202	_autoflush(\*TESTERR);
1182	1203	_autoflush(\*STDERR);
1183	1204
1184		$Test->output(\*TESTOUT);
1185		$Test->failure_output(\*TESTERR);
1186		$Test->todo_output(\*TESTOUT);
1187		}
1188
	1205	$self->output(\*TESTOUT);
	1206	$self->failure_output(\*TESTERR);
	1207	$self->todo_output(\*TESTOUT);
	1208	}
	1209
	1210
	1211	my $Opened_Testhandles = 0;
1189	1212	sub _open_testhandles {
	1213	return if $Opened_Testhandles;
1190	1214	# We dup STDOUT and STDERR so people can change them in their
1191	1215	# test suites while still getting normal test output.
1192	1216	open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";

1219	1243	sub current_test {
1220	1244	my($self, $num) = @_;
1221	1245
1222		lock($Curr_Test);
	1246	lock($self->{Curr_Test});
1223	1247	if( defined $num ) {
1224		unless( $Have_Plan ) {
	1248	unless( $self->{Have_Plan} ) {
1225	1249	require Carp;
1226	1250	Carp::croak("Can't change the current test number without a plan!");
1227	1251	}
1228	1252
1229		$Curr_Test = $num;
	1253	$self->{Curr_Test} = $num;
1230	1254
1231	1255	# If the test counter is being pushed forward fill in the details.
1232		if( $num > @Test_Results ) {
1233		my $start = @Test_Results ? $#Test_Results + 1 : 0;
	1256	my $test_results = $self->{Test_Results};
	1257	if( $num > @$test_results ) {
	1258	my $start = @$test_results ? @$test_results : 0;
1234	1259	for ($start..$num-1) {
1235		$Test_Results[$_] = &share({
	1260	$test_results->[$_] = &share({
1236	1261	'ok' => 1,
1237	1262	actual_ok => undef,
1238	1263	reason => 'incrementing test number',

1242	1267	}
1243	1268	}
1244	1269	# If backward, wipe history. Its their funeral.
1245		elsif( $num < @Test_Results ) {
1246		$#Test_Results = $num - 1;
	1270	elsif( $num < @$test_results ) {
	1271	$#{$test_results} = $num - 1;
1247	1272	}
1248	1273	}
1249		return $Curr_Test;
	1274	return $self->{Curr_Test};
1250	1275	}
1251	1276
1252	1277

1264	1289	sub summary {
1265	1290	my($self) = shift;
1266	1291
1267		return map { $_->{'ok'} } @Test_Results;
	1292	return map { $_->{'ok'} } @{ $self->{Test_Results} };
1268	1293	}
1269	1294
1270	1295	=item B<details>

1317	1342	=cut
1318	1343
1319	1344	sub details {
1320		return @Test_Results;
	1345	my $self = shift;
	1346	return @{ $self->{Test_Results} };
1321	1347	}
1322	1348
1323	1349	=item B<todo>

1330	1356	details). Returns the reason (ie. the value of $TODO) if running as
1331	1357	todo tests, false otherwise.
1332	1358
1333		todo() is pretty part about finding the right package to look for
1334		$TODO in. It uses the exported_to() package to find it. If that's
1335		not set, it's pretty good at guessing the right package to look at.
	1359	todo() is about finding the right package to look for $TODO in. It
	1360	uses the exported_to() package to find it. If that's not set, it's
	1361	pretty good at guessing the right package to look at based on $Level.
1336	1362
1337	1363	Sometimes there is some confusion about where todo() should be looking
1338	1364	for the $TODO variable. If you want to be sure, tell it explicitly

1343	1369	sub todo {
1344	1370	my($self, $pack) = @_;
1345	1371
1346		$pack = $pack \|\| $self->exported_to \|\| $self->caller(1);
	1372	$pack = $pack \|\| $self->exported_to \|\| $self->caller($Level);
	1373	return 0 unless $pack;
1347	1374
1348	1375	no strict 'refs';
1349	1376	return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}

1378	1405
1379	1406	=item B<_sanity_check>
1380	1407
1381		_sanity_check();
	1408	$self->_sanity_check();
1382	1409
1383	1410	Runs a bunch of end of test sanity checks to make sure reality came
1384	1411	through ok. If anything is wrong it will die with a fairly friendly

1388	1415
1389	1416	#'#
1390	1417	sub _sanity_check {
1391		_whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
1392		_whoa(!$Have_Plan and $Curr_Test,
	1418	my $self = shift;
	1419
	1420	_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
	1421	_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1393	1422	'Somehow your tests ran without a plan!');
1394		_whoa($Curr_Test != @Test_Results,
	1423	_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1395	1424	'Somehow you got a different number of results than tests ran!');
1396	1425	}
1397	1426

1448	1477	for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1449	1478	$in_eval = 1 if $sub =~ /^$eval$/;
1450	1479	}
1451		$Test_Died = 1 unless $in_eval;
	1480	$Test->{Test_Died} = 1 unless $in_eval;
1452	1481	};
1453	1482
1454	1483	sub _ending {
1455	1484	my $self = shift;
1456	1485
1457		_sanity_check();
	1486	$self->_sanity_check();
1458	1487
1459	1488	# Don't bother with an ending if this is a forked copy. Only the parent
1460	1489	# should do the ending.
1461		do{ _my_exit($?) && return } if $Original_Pid != $$;
1462
1463		# Bailout if plan() was never called. This is so
1464		# "require Test::Simple" doesn't puke.
1465		do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
	1490	# Exit if plan() was never called. This is so "require Test::Simple"
	1491	# doesn't puke.
	1492	if( ($self->{Original_Pid} != $$) or
	1493	(!$self->{Have_Plan} && !$self->{Test_Died}) )
	1494	{
	1495	_my_exit($?);
	1496	return;
	1497	}
1466	1498
1467	1499	# Figure out if we passed or failed and print helpful messages.
1468		if( @Test_Results ) {
	1500	my $test_results = $self->{Test_Results};
	1501	if( @$test_results ) {
1469	1502	# The plan? We have no plan.
1470		if( $No_Plan ) {
1471		$self->_print("1..$Curr_Test\n") unless $self->no_header;
1472		$Expected_Tests = $Curr_Test;
	1503	if( $self->{No_Plan} ) {
	1504	$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
	1505	$self->{Expected_Tests} = $self->{Curr_Test};
1473	1506	}
1474	1507
1475	1508	# Auto-extended arrays and elements which aren't explicitly
1476	1509	# filled in with a shared reference will puke under 5.8.0
1477	1510	# ithreads. So we have to fill them in by hand. :(
1478	1511	my $empty_result = &share({});
1479		for my $idx ( 0..$Expected_Tests-1 ) {
1480		$Test_Results[$idx] = $empty_result
1481		unless defined $Test_Results[$idx];
	1512	for my $idx ( 0..$self->{Expected_Tests}-1 ) {
	1513	$test_results->[$idx] = $empty_result
	1514	unless defined $test_results->[$idx];
1482	1515	}
1483	1516
1484		my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
1485		$num_failed += abs($Expected_Tests - @Test_Results);
1486
1487		if( $Curr_Test < $Expected_Tests ) {
1488		my $s = $Expected_Tests == 1 ? '' : 's';
	1517	my $num_failed = grep !$_->{'ok'},
	1518	@{$test_results}[0..$self->{Expected_Tests}-1];
	1519	$num_failed += abs($self->{Expected_Tests} - @$test_results);
	1520
	1521	if( $self->{Curr_Test} < $self->{Expected_Tests} ) {
	1522	my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1489	1523	$self->diag(<<"FAIL");
1490		Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.
	1524	Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1491	1525	FAIL
1492	1526	}
1493		elsif( $Curr_Test > $Expected_Tests ) {
1494		my $num_extra = $Curr_Test - $Expected_Tests;
1495		my $s = $Expected_Tests == 1 ? '' : 's';
	1527	elsif( $self->{Curr_Test} > $self->{Expected_Tests} ) {
	1528	my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
	1529	my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1496	1530	$self->diag(<<"FAIL");
1497		Looks like you planned $Expected_Tests test$s but ran $num_extra extra.
	1531	Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1498	1532	FAIL
1499	1533	}
1500	1534	elsif ( $num_failed ) {
1501	1535	my $s = $num_failed == 1 ? '' : 's';
1502	1536	$self->diag(<<"FAIL");
1503		Looks like you failed $num_failed test$s of $Expected_Tests.
	1537	Looks like you failed $num_failed test$s of $self->{Expected_Tests}.
1504	1538	FAIL
1505	1539	}
1506	1540
1507		if( $Test_Died ) {
	1541	if( $self->{Test_Died} ) {
1508	1542	$self->diag(<<"FAIL");
1509		Looks like your test died just after $Curr_Test.
	1543	Looks like your test died just after $self->{Curr_Test}.
1510	1544	FAIL
1511	1545
1512	1546	_my_exit( 255 ) && return;

1514	1548
1515	1549	_my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
1516	1550	}
1517		elsif ( $Skip_All ) {
	1551	elsif ( $self->{Skip_All} ) {
1518	1552	_my_exit( 0 ) && return;
1519	1553	}
1520		elsif ( $Test_Died ) {
	1554	elsif ( $self->{Test_Died} ) {
1521	1555	$self->diag(<<'FAIL');
1522	1556	Looks like your test died before it could output anything.
1523	1557	FAIL

+93

-48

t/Test/More.pm less more

17	17
18	18	require Exporter;
19	19	use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
20		$VERSION = '0.54';
	20	$VERSION = '0.60';
21	21	$VERSION = eval $VERSION; # make the alpha version come out as a number
22	22
23	23	@ISA = qw(Exporter);

99	99	pass($test_name);
100	100	fail($test_name);
101	101
102		# Utility comparison functions.
103		eq_array(\@this, \@that);
104		eq_hash(\%this, \%that);
105		eq_set(\@this, \@that);
106
107	102	# UNIMPLEMENTED!!!
108	103	my @status = Test::More::status;
109	104

141	136	use Test::More qw(no_plan);
142	137
143	138	B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
144		think everything has failed. See L<BUGS and CAVEATS>)
	139	think everything has failed. See L<BUGS>)
145	140
146	141	In some cases, you'll want to completely skip an entire testing script.
147	142

804	799	# End with an alphanumeric.
805	800	# The rest is an alphanumeric or ::
806	801	$module =~ s/\b::\b//g;
807		$module =~ /^[a-zA-Z]\w+$/;
	802	$module =~ /^[a-zA-Z]\w*$/;
808	803	}
809	804
810	805	=back

926	921	When the block is empty, delete it.
927	922
928	923	B<NOTE>: TODO tests require a Test::Harness upgrade else it will
929		treat it as a normal failure. See L<BUGS and CAVEATS>)
	924	treat it as a normal failure. See L<BUGS>)
930	925
931	926
932	927	=item B<todo_skip>

981	976
982	977	=back
983	978
984		=head2 Comparison functions
	979	=head2 Complex data structures
985	980
986	981	Not everything is a simple eq check or regex. There are times you
987		need to see if two arrays are equivalent, for instance. For these
988		instances, Test::More provides a handful of useful functions.
	982	need to see if two data structures are equivalent. For these
	983	instances Test::More provides a handful of useful functions.
989	984
990	985	B<NOTE> I'm not quite sure what will happen with filehandles.
991	986

1002	997
1003	998	Test::Differences and Test::Deep provide more in-depth functionality
1004	999	along these lines.
	1000
	1001	=back
1005	1002
1006	1003	=cut
1007	1004

1017	1014	chop $msg; # clip off newline so carp() will put in line/file
1018	1015
1019	1016	_carp sprintf $msg, scalar @_;
	1017
	1018	return $Test->ok(0);
1020	1019	}
1021	1020
1022	1021	my($this, $that, $name) = @_;
1023	1022
1024	1023	my $ok;
1025		if( !ref $this xor !ref $that ) { # one's a reference, one isn't
1026		$ok = 0;
1027		}
1028		if( !ref $this and !ref $that ) {
	1024	if( !ref $this and !ref $that ) { # neither is a reference
1029	1025	$ok = $Test->is_eq($this, $that, $name);
1030	1026	}
1031		else {
	1027	elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
	1028	$ok = $Test->ok(0, $name);
	1029	$Test->diag( _format_stack({ vals => [ $this, $that ] }) );
	1030	}
	1031	else { # both references
1032	1032	local @Data_Stack = ();
1033		local %Refs_Seen = ();
1034	1033	if( _deep_check($this, $that) ) {
1035	1034	$ok = $Test->ok(1, $name);
1036	1035	}
1037	1036	else {
1038	1037	$ok = $Test->ok(0, $name);
1039		$ok = $Test->diag(_format_stack(@Data_Stack));
	1038	$Test->diag(_format_stack(@Data_Stack));
1040	1039	}
1041	1040	}
1042	1041

1072	1071	my $out = "Structures begin differing at:\n";
1073	1072	foreach my $idx (0..$#vals) {
1074	1073	my $val = $vals[$idx];
1075		$vals[$idx] = !defined $val ? 'undef' :
1076		$val eq $DNE ? "Does not exist"
1077		: "'$val'";
	1074	$vals[$idx] = !defined $val ? 'undef' :
	1075	$val eq $DNE ? "Does not exist" :
	1076	ref $val ? "$val" :
	1077	"'$val'";
1078	1078	}
1079	1079
1080	1080	$out .= "$vars[0] = $vals[0]\n";

1098	1098	}
1099	1099
1100	1100
	1101	=head2 Discouraged comparison functions
	1102
	1103	The use of the following functions is discouraged as they are not
	1104	actually testing functions and produce no diagnostics to help figure
	1105	out what went wrong. They were written before is_deeply() existed
	1106	because I couldn't figure out how to display a useful diff of two
	1107	arbitrary data structures.
	1108
	1109	These functions are usually used inside an ok().
	1110
	1111	ok( eq_array(\@this, \@that) );
	1112
	1113	C<is_deeply()> can do that better and with diagnostics.
	1114
	1115	is_deeply( \@this, \@that );
	1116
	1117	They may be deprecated in future versions.
	1118
	1119	=over 4
	1120
1101	1121	=item B<eq_array>
1102	1122
1103		eq_array(\@this, \@that);
	1123	my $is_eq = eq_array(\@this, \@that);
1104	1124
1105	1125	Checks if two arrays are equivalent. This is a deep check, so
1106	1126	multi-level structures are handled correctly.

1110	1130	#'#
1111	1131	sub eq_array {
1112	1132	local @Data_Stack;
1113		local %Refs_Seen;
1114		_eq_array(@_);
	1133	_deep_check(@_);
1115	1134	}
1116	1135
1117	1136	sub _eq_array {

1123	1142	}
1124	1143
1125	1144	return 1 if $a1 eq $a2;
1126
1127		if($Refs_Seen{$a1}) {
1128		return $Refs_Seen{$a1} eq $a2;
1129		}
1130		else {
1131		$Refs_Seen{$a1} = "$a2";
1132		}
1133	1145
1134	1146	my $ok = 1;
1135	1147	my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;

1151	1163	my($e1, $e2) = @_;
1152	1164	my $ok = 0;
1153	1165
	1166	# Effectively turn %Refs_Seen into a stack. This avoids picking up
	1167	# the same referenced used twice (such as [\$a, \$a]) to be considered
	1168	# circular.
	1169	local %Refs_Seen = %Refs_Seen;
	1170
1154	1171	{
1155	1172	# Quiet uninitialized value warnings when comparing undefs.
1156	1173	local $^W = 0;

1159	1176
1160	1177	# Either they're both references or both not.
1161	1178	my $same_ref = !(!ref $e1 xor !ref $e2);
	1179	my $not_ref = (!ref $e1 and !ref $e2);
1162	1180
1163	1181	if( defined $e1 xor defined $e2 ) {
1164	1182	$ok = 0;

1169	1187	elsif ( $same_ref and ($e1 eq $e2) ) {
1170	1188	$ok = 1;
1171	1189	}
	1190	elsif ( $not_ref ) {
	1191	push @Data_Stack, { type => '', vals => [$e1, $e2] };
	1192	$ok = 0;
	1193	}
1172	1194	else {
	1195	if( $Refs_Seen{$e1} ) {
	1196	return $Refs_Seen{$e1} eq $e2;
	1197	}
	1198	else {
	1199	$Refs_Seen{$e1} = "$e2";
	1200	}
	1201
1173	1202	my $type = _type($e1);
1174		$type = '' unless _type($e2) eq $type;
1175
1176		if( !$type ) {
1177		push @Data_Stack, { vals => [$e1, $e2] };
	1203	$type = 'DIFFERENT' unless _type($e2) eq $type;
	1204
	1205	if( $type eq 'DIFFERENT' ) {
	1206	push @Data_Stack, { type => $type, vals => [$e1, $e2] };
1178	1207	$ok = 0;
1179	1208	}
1180	1209	elsif( $type eq 'ARRAY' ) {

1184	1213	$ok = _eq_hash($e1, $e2);
1185	1214	}
1186	1215	elsif( $type eq 'REF' ) {
1187		push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
	1216	push @Data_Stack, { type => $type, vals => [$e1, $e2] };
1188	1217	$ok = _deep_check($$e1, $$e2);
1189	1218	pop @Data_Stack if $ok;
1190	1219	}

1193	1222	$ok = _deep_check($$e1, $$e2);
1194	1223	pop @Data_Stack if $ok;
1195	1224	}
	1225	else {
	1226	_whoa(1, "No type in _deep_check");
	1227	}
1196	1228	}
1197	1229	}
1198	1230

1200	1232	}
1201	1233
1202	1234
	1235	sub _whoa {
	1236	my($check, $desc) = @_;
	1237	if( $check ) {
	1238	die <<WHOA;
	1239	WHOA! $desc
	1240	This should never happen! Please contact the author immediately!
	1241	WHOA
	1242	}
	1243	}
	1244
	1245
1203	1246	=item B<eq_hash>
1204	1247
1205		eq_hash(\%this, \%that);
	1248	my $is_eq = eq_hash(\%this, \%that);
1206	1249
1207	1250	Determines if the two hashes contain the same keys and values. This
1208	1251	is a deep check.

1211	1254
1212	1255	sub eq_hash {
1213	1256	local @Data_Stack;
1214		local %Refs_Seen;
1215		return _eq_hash(@_);
	1257	return _deep_check(@_);
1216	1258	}
1217	1259
1218	1260	sub _eq_hash {

1224	1266	}
1225	1267
1226	1268	return 1 if $a1 eq $a2;
1227
1228		if( $Refs_Seen{$a1} ) {
1229		return $Refs_Seen{$a1} eq $a2;
1230		}
1231		else {
1232		$Refs_Seen{$a1} = "$a2";
1233		}
1234	1269
1235	1270	my $ok = 1;
1236	1271	my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;

1250	1285
1251	1286	=item B<eq_set>
1252	1287
1253		eq_set(\@this, \@that);
	1288	my $is_eq = eq_set(\@this, \@that);
1254	1289
1255	1290	Similar to eq_array(), except the order of the elements is B<not>
1256	1291	important. This is a deep check, but the irrelevancy of order only
1257	1292	applies to the top level.
1258	1293
	1294	ok( eq_set(\@this, \@that) );
	1295
	1296	Is better written:
	1297
	1298	is_deeply( [sort @this], [sort @that] );
	1299
1259	1300	B<NOTE> By historical accident, this is not a true set comparision.
1260	1301	While the order of elements does not matter, duplicate elements do.
	1302
	1303	Test::Deep contains much better set comparison functions.
1261	1304
1262	1305	=cut
1263	1306

1329	1372
1330	1373	If you fail more than 254 tests, it will be reported as 254.
1331	1374
	1375	B<NOTE> This behavior may go away in future versions.
	1376
1332	1377
1333	1378	=head1 CAVEATS and NOTES
1334	1379

+259

-257

t/btree.t less more

4	4	use lib 't';
5	5	use BerkeleyDB;
6	6	use util ;
7
8		print "1..244\n";
	7	use Test::More;
	8
	9	plan tests => 244;
9	10
10	11	my $Dfile = "dbhash.tmp";
11	12	my $Dfile2 = "dbhash2.tmp";

20	21	# Check for invalid parameters
21	22	my $db ;
22	23	eval ' $db = new BerkeleyDB::Btree -Stupid => 3 ; ' ;
23		ok 1, $@ =~ /unknown key value$s$ Stupid/ ;
	24	ok $@ =~ /unknown key value$s$ Stupid/ ;
24	25
25	26	eval ' $db = new BerkeleyDB::Btree -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
26		ok 2, $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
	27	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/
27	28	or print "# $@" ;
28	29
29	30	eval ' $db = new BerkeleyDB::Btree -Env => 2 ' ;
30		ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	31	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
31	32
32	33	eval ' $db = new BerkeleyDB::Btree -Txn => "x" ' ;
33		ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
	34	ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
34	35
35	36	my $obj = bless [], "main" ;
36	37	eval ' $db = new BerkeleyDB::Btree -Env => $obj ' ;
37		ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	38	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
38	39	}
39	40
40	41	# Now check the interface to Btree

42	43	{
43	44	my $lex = new LexFile $Dfile ;
44	45
45		ok 6, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	46	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
46	47	-Flags => DB_CREATE ;
47	48
48	49	# Add a k/v pair
49	50	my $value ;
50	51	my $status ;
51		ok 7, $db->db_put("some key", "some value") == 0 ;
52		ok 8, $db->status() == 0 ;
53		ok 9, $db->db_get("some key", $value) == 0 ;
54		ok 10, $value eq "some value" ;
55		ok 11, $db->db_put("key", "value") == 0 ;
56		ok 12, $db->db_get("key", $value) == 0 ;
57		ok 13, $value eq "value" ;
58		ok 14, $db->db_del("some key") == 0 ;
59		ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
60		ok 16, $db->status() == DB_NOTFOUND ;
61		ok 17, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
62
63		ok 18, $db->db_sync() == 0 ;
	52	ok $db->db_put("some key", "some value") == 0 ;
	53	ok $db->status() == 0 ;
	54	ok $db->db_get("some key", $value) == 0 ;
	55	ok $value eq "some value" ;
	56	ok $db->db_put("key", "value") == 0 ;
	57	ok $db->db_get("key", $value) == 0 ;
	58	ok $value eq "value" ;
	59	ok $db->db_del("some key") == 0 ;
	60	ok $db->db_get("some key", $value) == DB_NOTFOUND ;
	61	ok $db->status() == DB_NOTFOUND ;
	62	ok $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
	63
	64	ok $db->db_sync() == 0 ;
64	65
65	66	# Check NOOVERWRITE will make put fail when attempting to overwrite
66	67	# an existing record.
67	68
68		ok 19, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
69		ok 20, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
70		ok 21, $db->status() == DB_KEYEXIST ;
	69	ok $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
	70	ok $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
	71	ok $db->status() == DB_KEYEXIST ;
71	72
72	73
73	74	# check that the value of the key has not been changed by the
74	75	# previous test
75		ok 22, $db->db_get("key", $value) == 0 ;
76		ok 23, $value eq "value" ;
	76	ok $db->db_get("key", $value) == 0 ;
	77	ok $value eq "value" ;
77	78
78	79	# test DB_GET_BOTH
79	80	my ($k, $v) = ("key", "value") ;
80		ok 24, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
	81	ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
81	82
82	83	($k, $v) = ("key", "fred") ;
83		ok 25, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	84	ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
84	85
85	86	($k, $v) = ("another", "value") ;
86		ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	87	ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
87	88
88	89
89	90	}

93	94	my $lex = new LexFile $Dfile ;
94	95
95	96	my $home = "./fred" ;
96		ok 27, my $lexD = new LexDir($home) ;
97
98		ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
	97	ok my $lexD = new LexDir($home) ;
	98
	99	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
99	100	@StdErrFile, -Home => $home ;
100		ok 29, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	101	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
101	102	-Env => $env,
102	103	-Flags => DB_CREATE ;
103	104
104	105	# Add a k/v pair
105	106	my $value ;
106		ok 30, $db->db_put("some key", "some value") == 0 ;
107		ok 31, $db->db_get("some key", $value) == 0 ;
108		ok 32, $value eq "some value" ;
	107	ok $db->db_put("some key", "some value") == 0 ;
	108	ok $db->db_get("some key", $value) == 0 ;
	109	ok $value eq "some value" ;
109	110	undef $db ;
110	111	undef $env ;
111	112	}

117	118	my $lex = new LexFile $Dfile ;
118	119	my %hash ;
119	120	my ($k, $v) ;
120		ok 33, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	121	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
121	122	-Flags => DB_CREATE ;
122	123	#print "[$db] [$!] $BerkeleyDB::Error\n" ;
123	124

132	133	while (($k, $v) = each %data) {
133	134	$ret += $db->db_put($k, $v) ;
134	135	}
135		ok 34, $ret == 0 ;
	136	ok $ret == 0 ;
136	137
137	138	# create the cursor
138		ok 35, my $cursor = $db->db_cursor() ;
	139	ok my $cursor = $db->db_cursor() ;
139	140
140	141	$k = $v = "" ;
141	142	my %copy = %data ;

147	148	else
148	149	{ ++ $extras }
149	150	}
150		ok 36, $cursor->status() == DB_NOTFOUND ;
151		ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'};
152		ok 38, keys %copy == 0 ;
153		ok 39, $extras == 0 ;
	151	ok $cursor->status() == DB_NOTFOUND ;
	152	ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'};
	153	ok keys %copy == 0 ;
	154	ok $extras == 0 ;
154	155
155	156	# sequence backwards
156	157	%copy = %data ;

164	165	else
165	166	{ ++ $extras }
166	167	}
167		ok 40, $status == DB_NOTFOUND ;
168		ok 41, $status eq $DB_errors{'DB_NOTFOUND'};
169		ok 42, $cursor->status() == $status ;
170		ok 43, $cursor->status() eq $status ;
171		ok 44, keys %copy == 0 ;
172		ok 45, $extras == 0 ;
	168	ok $status == DB_NOTFOUND ;
	169	ok $status eq $DB_errors{'DB_NOTFOUND'};
	170	ok $cursor->status() == $status ;
	171	ok $cursor->status() eq $status ;
	172	ok keys %copy == 0 ;
	173	ok $extras == 0 ;
173	174
174	175	($k, $v) = ("green", "house") ;
175		ok 46, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
	176	ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
176	177
177	178	($k, $v) = ("green", "door") ;
178		ok 47, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	179	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
179	180
180	181	($k, $v) = ("black", "house") ;
181		ok 48, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	182	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
182	183
183	184	}
184	185

187	188
188	189	my $lex = new LexFile $Dfile ;
189	190	my %hash ;
190		ok 49, tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
	191	ok tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
191	192	-Flags => DB_CREATE ;
192	193
193	194	# check "each" with an empty database

195	196	while (my ($k, $v) = each %hash) {
196	197	++ $count ;
197	198	}
198		ok 50, (tied %hash)->status() == DB_NOTFOUND ;
199		ok 51, $count == 0 ;
	199	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	200	ok $count == 0 ;
200	201
201	202	# Add a k/v pair
202	203	my $value ;
203	204	$hash{"some key"} = "some value";
204		ok 52, (tied %hash)->status() == 0 ;
205		ok 53, $hash{"some key"} eq "some value";
206		ok 54, defined $hash{"some key"} ;
207		ok 55, (tied %hash)->status() == 0 ;
208		ok 56, exists $hash{"some key"} ;
209		ok 57, !defined $hash{"jimmy"} ;
210		ok 58, (tied %hash)->status() == DB_NOTFOUND ;
211		ok 59, !exists $hash{"jimmy"} ;
212		ok 60, (tied %hash)->status() == DB_NOTFOUND ;
	205	ok ((tied %hash)->status() == 0) ;
	206	ok $hash{"some key"} eq "some value";
	207	ok defined $hash{"some key"} ;
	208	ok ((tied %hash)->status() == 0) ;
	209	ok exists $hash{"some key"} ;
	210	ok !defined $hash{"jimmy"} ;
	211	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	212	ok !exists $hash{"jimmy"} ;
	213	ok ((tied %hash)->status() == DB_NOTFOUND) ;
213	214
214	215	delete $hash{"some key"} ;
215		ok 61, (tied %hash)->status() == 0 ;
216		ok 62, ! defined $hash{"some key"} ;
217		ok 63, (tied %hash)->status() == DB_NOTFOUND ;
218		ok 64, ! exists $hash{"some key"} ;
219		ok 65, (tied %hash)->status() == DB_NOTFOUND ;
	216	ok ((tied %hash)->status() == 0) ;
	217	ok ! defined $hash{"some key"} ;
	218	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	219	ok ! exists $hash{"some key"} ;
	220	ok ((tied %hash)->status() == DB_NOTFOUND) ;
220	221
221	222	$hash{1} = 2 ;
222	223	$hash{10} = 20 ;

229	230	$values += $v ;
230	231	++ $count ;
231	232	}
232		ok 66, $count == 3 ;
233		ok 67, $keys == 1011 ;
234		ok 68, $values == 2022 ;
	233	ok $count == 3 ;
	234	ok $keys == 1011 ;
	235	ok $values == 2022 ;
235	236
236	237	# now clear the hash
237	238	%hash = () ;
238		ok 69, keys %hash == 0 ;
	239	ok keys %hash == 0 ;
239	240
240	241	untie %hash ;
241	242	}

246	247	my $value ;
247	248	my (%h, %g, %k) ;
248	249	my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
249		ok 70, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	250	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
250	251	-Compare => sub { $_[0] <=> $_[1] },
251	252	-Flags => DB_CREATE ;
252	253
253		ok 71, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	254	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
254	255	-Compare => sub { $_[0] cmp $_[1] },
255	256	-Flags => DB_CREATE ;
256	257
257		ok 72, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
	258	ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
258	259	-Compare => sub { length $_[0] <=> length $_[1] },
259	260	-Flags => DB_CREATE ;
260	261

286	287	1 ;
287	288	}
288	289
289		ok 73, ArrayCompare (\@srt_1, [keys %h]);
290		ok 74, ArrayCompare (\@srt_2, [keys %g]);
291		ok 75, ArrayCompare (\@srt_3, [keys %k]);
	290	ok ArrayCompare (\@srt_1, [keys %h]);
	291	ok ArrayCompare (\@srt_2, [keys %g]);
	292	ok ArrayCompare (\@srt_3, [keys %k]);
292	293
293	294	}
294	295

299	300	my (%h, %g, %k) ;
300	301	my @Keys = qw( 0123 9 12 -1234 9 987654321 def ) ;
301	302	my @Values = qw( 1 0 3 dd x abc 0 ) ;
302		ok 76, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	303	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
303	304	-Compare => sub { $_[0] <=> $_[1] },
304	305	-Property => DB_DUP,
305	306	-Flags => DB_CREATE ;
306	307
307		ok 77, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	308	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
308	309	-Compare => sub { $_[0] cmp $_[1] },
309	310	-Property => DB_DUP,
310	311	-Flags => DB_CREATE ;
311	312
312		ok 78, tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
	313	ok tie %k, 'BerkeleyDB::Btree', -Filename => $Dfile3,
313	314	-Compare => sub { length $_[0] <=> length $_[1] },
314	315	-Property => DB_DUP,
315	316	-Flags => DB_CREATE ;

342	343	return @values ;
343	344	}
344	345
345		ok 79, ArrayCompare (\@srt_1, [keys %h]);
346		ok 80, ArrayCompare (\@srt_2, [keys %g]);
347		ok 81, ArrayCompare (\@srt_3, [keys %k]);
348		ok 82, ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]);
349		ok 83, ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]);
350		ok 84, ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]);
	346	ok ArrayCompare (\@srt_1, [keys %h]);
	347	ok ArrayCompare (\@srt_2, [keys %g]);
	348	ok ArrayCompare (\@srt_3, [keys %k]);
	349	ok ArrayCompare ([qw(dd 0 0 x 3 1 abc)], [getValues \%h]);
	350	ok ArrayCompare ([qw(dd 1 0 3 x abc 0)], [getValues \%g]);
	351	ok ArrayCompare ([qw(0 x 3 0 1 dd abc)], [getValues \%k]);
351	352
352	353	# test DB_DUP_NEXT
353		ok 85, my $cur = (tied %g)->db_cursor() ;
	354	ok my $cur = (tied %g)->db_cursor() ;
354	355	my ($k, $v) = (9, "") ;
355		ok 86, $cur->c_get($k, $v, DB_SET) == 0 ;
356		ok 87, $k == 9 && $v == 0 ;
357		ok 88, $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
358		ok 89, $k == 9 && $v eq "x" ;
359		ok 90, $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
	356	ok $cur->c_get($k, $v, DB_SET) == 0 ;
	357	ok $k == 9 && $v == 0 ;
	358	ok $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
	359	ok $k == 9 && $v eq "x" ;
	360	ok $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
360	361	}
361	362
362	363	{

366	367	my (%h, %g) ;
367	368	my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
368	369	my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
369		ok 91, tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
	370	ok tie %h, "BerkeleyDB::Btree", -Filename => $Dfile,
370	371	-Compare => sub { $_[0] <=> $_[1] },
371	372	-DupCompare => sub { $_[0] cmp $_[1] },
372	373	-Property => DB_DUP,
373	374	-Flags => DB_CREATE ;
374	375
375		ok 92, tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
	376	ok tie %g, 'BerkeleyDB::Btree', -Filename => $Dfile2,
376	377	-Compare => sub { $_[0] cmp $_[1] },
377	378	-DupCompare => sub { $_[0] <=> $_[1] },
378	379	-Property => DB_DUP,

394	395	$g{$_} = $value ;
395	396	}
396	397
397		ok 93, ArrayCompare (\@srt_1, [keys %h]);
398		ok 94, ArrayCompare (\@srt_2, [keys %g]);
399		ok 95, ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]);
400		ok 96, ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]);
	398	ok ArrayCompare (\@srt_1, [keys %h]);
	399	ok ArrayCompare (\@srt_2, [keys %g]);
	400	ok ArrayCompare ([qw(dd 1 3 x 2 11 abc 0)], [getValues \%g]);
	401	ok ArrayCompare ([qw(dd 0 11 2 x 3 1 abc)], [getValues \%h]);
401	402
402	403	}
403	404

406	407	my $lex = new LexFile $Dfile;
407	408	my %hh ;
408	409
409		ok 97, my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
	410	ok my $YY = tie %hh, "BerkeleyDB::Btree", -Filename => $Dfile,
410	411	-DupCompare => sub { $_[0] cmp $_[1] },
411	412	-Property => DB_DUP,
412	413	-Flags => DB_CREATE ;

418	419	$hh{'mouse'} = 'mickey' ;
419	420
420	421	# first work in scalar context
421		ok 98, scalar $YY->get_dup('Unknown') == 0 ;
422		ok 99, scalar $YY->get_dup('Smith') == 1 ;
423		ok 100, scalar $YY->get_dup('Wall') == 3 ;
	422	ok scalar $YY->get_dup('Unknown') == 0 ;
	423	ok scalar $YY->get_dup('Smith') == 1 ;
	424	ok scalar $YY->get_dup('Wall') == 3 ;
424	425
425	426	# now in list context
426	427	my @unknown = $YY->get_dup('Unknown') ;
427		ok 101, "@unknown" eq "" ;
	428	ok "@unknown" eq "" ;
428	429
429	430	my @smith = $YY->get_dup('Smith') ;
430		ok 102, "@smith" eq "John" ;
	431	ok "@smith" eq "John" ;
431	432
432	433	{
433	434	my @wall = $YY->get_dup('Wall') ;
434	435	my %wall ;
435	436	@wall{@wall} = @wall ;
436		ok 103, (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
	437	ok (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'});
437	438	}
438	439
439	440	# hash
440	441	my %unknown = $YY->get_dup('Unknown', 1) ;
441		ok 104, keys %unknown == 0 ;
	442	ok keys %unknown == 0 ;
442	443
443	444	my %smith = $YY->get_dup('Smith', 1) ;
444		ok 105, keys %smith == 1 && $smith{'John'} ;
	445	ok keys %smith == 1 && $smith{'John'} ;
445	446
446	447	my %wall = $YY->get_dup('Wall', 1) ;
447		ok 106, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
	448	ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
448	449	&& $wall{'Brick'} == 1 ;
449	450
450	451	undef $YY ;

459	460	my %hash ;
460	461	my $fd ;
461	462	my $value ;
462		ok 107, my $db = tie %hash, 'BerkeleyDB::Btree' ;
463
464		ok 108, $db->db_put("some key", "some value") == 0 ;
465		ok 109, $db->db_get("some key", $value) == 0 ;
466		ok 110, $value eq "some value" ;
	463	ok my $db = tie %hash, 'BerkeleyDB::Btree' ;
	464
	465	ok $db->db_put("some key", "some value") == 0 ;
	466	ok $db->db_get("some key", $value) == 0 ;
	467	ok $value eq "some value" ;
467	468
468	469	}
469	470

473	474
474	475	my $lex = new LexFile $Dfile ;
475	476	my $value ;
476		ok 111, my $db = new BerkeleyDB::Btree, -Filename => $Dfile,
477		-Flags => DB_CREATE ;
	477	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	478	-Flags => DB_CREATE ;
478	479
479	480	# create some data
480	481	my %data = (

487	488	while (my ($k, $v) = each %data) {
488	489	$ret += $db->db_put($k, $v) ;
489	490	}
490		ok 112, $ret == 0 ;
	491	ok $ret == 0 ;
491	492
492	493
493	494	# do a partial get
494	495	my ($pon, $off, $len) = $db->partial_set(0,2) ;
495		ok 113, ! $pon && $off == 0 && $len == 0 ;
496		ok 114, $db->db_get("red", $value) == 0 && $value eq "bo" ;
497		ok 115, $db->db_get("green", $value) == 0 && $value eq "ho" ;
498		ok 116, $db->db_get("blue", $value) == 0 && $value eq "se" ;
	496	ok ! $pon && $off == 0 && $len == 0 ;
	497	ok $db->db_get("red", $value) == 0 && $value eq "bo" ;
	498	ok $db->db_get("green", $value) == 0 && $value eq "ho" ;
	499	ok $db->db_get("blue", $value) == 0 && $value eq "se" ;
499	500
500	501	# do a partial get, off end of data
501	502	($pon, $off, $len) = $db->partial_set(3,2) ;
502		ok 117, $pon ;
503		ok 118, $off == 0 ;
504		ok 119, $len == 2 ;
505		ok 120, $db->db_get("red", $value) == 0 && $value eq "t" ;
506		ok 121, $db->db_get("green", $value) == 0 && $value eq "se" ;
507		ok 122, $db->db_get("blue", $value) == 0 && $value eq "" ;
	503	ok $pon ;
	504	ok $off == 0 ;
	505	ok $len == 2 ;
	506	ok $db->db_get("red", $value) == 0 && $value eq "t" ;
	507	ok $db->db_get("green", $value) == 0 && $value eq "se" ;
	508	ok $db->db_get("blue", $value) == 0 && $value eq "" ;
508	509
509	510	# switch of partial mode
510	511	($pon, $off, $len) = $db->partial_clear() ;
511		ok 123, $pon ;
512		ok 124, $off == 3 ;
513		ok 125, $len == 2 ;
514		ok 126, $db->db_get("red", $value) == 0 && $value eq "boat" ;
515		ok 127, $db->db_get("green", $value) == 0 && $value eq "house" ;
516		ok 128, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
	512	ok $pon ;
	513	ok $off == 3 ;
	514	ok $len == 2 ;
	515	ok $db->db_get("red", $value) == 0 && $value eq "boat" ;
	516	ok $db->db_get("green", $value) == 0 && $value eq "house" ;
	517	ok $db->db_get("blue", $value) == 0 && $value eq "sea" ;
517	518
518	519	# now partial put
519	520	$db->partial_set(0,2) ;
520		ok 129, $db->db_put("red", "") == 0 ;
521		ok 130, $db->db_put("green", "AB") == 0 ;
522		ok 131, $db->db_put("blue", "XYZ") == 0 ;
523		ok 132, $db->db_put("new", "KLM") == 0 ;
	521	ok $db->db_put("red", "") == 0 ;
	522	ok $db->db_put("green", "AB") == 0 ;
	523	ok $db->db_put("blue", "XYZ") == 0 ;
	524	ok $db->db_put("new", "KLM") == 0 ;
524	525
525	526	($pon, $off, $len) = $db->partial_clear() ;
526		ok 133, $pon ;
527		ok 134, $off == 0 ;
528		ok 135, $len == 2 ;
529		ok 136, $db->db_get("red", $value) == 0 && $value eq "at" ;
530		ok 137, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
531		ok 138, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
532		ok 139, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
	527	ok $pon ;
	528	ok $off == 0 ;
	529	ok $len == 2 ;
	530	ok $db->db_get("red", $value) == 0 && $value eq "at" ;
	531	ok $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
	532	ok $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
	533	ok $db->db_get("new", $value) == 0 && $value eq "KLM" ;
533	534
534	535	# now partial put
535	536	($pon, $off, $len) = $db->partial_set(3,2) ;
536		ok 140, ! $pon ;
537		ok 141, $off == 0 ;
538		ok 142, $len == 0 ;
539		ok 143, $db->db_put("red", "PPP") == 0 ;
540		ok 144, $db->db_put("green", "Q") == 0 ;
541		ok 145, $db->db_put("blue", "XYZ") == 0 ;
542		ok 146, $db->db_put("new", "TU") == 0 ;
	537	ok ! $pon ;
	538	ok $off == 0 ;
	539	ok $len == 0 ;
	540	ok $db->db_put("red", "PPP") == 0 ;
	541	ok $db->db_put("green", "Q") == 0 ;
	542	ok $db->db_put("blue", "XYZ") == 0 ;
	543	ok $db->db_put("new", "TU") == 0 ;
543	544
544	545	$db->partial_clear() ;
545		ok 147, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
546		ok 148, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
547		ok 149, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
548		ok 150, $db->db_get("new", $value) == 0 && $value eq "KLMTU" ;
	546	ok $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
	547	ok $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
	548	ok $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
	549	ok $db->db_get("new", $value) == 0 && $value eq "KLMTU" ;
549	550	}
550	551
551	552	{

555	556	my $lex = new LexFile $Dfile ;
556	557	my %hash ;
557	558	my $value ;
558		ok 151, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
	559	ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
559	560	-Flags => DB_CREATE ;
560	561
561	562	# create some data

572	573
573	574	# do a partial get
574	575	$db->partial_set(0,2) ;
575		ok 152, $hash{"red"} eq "bo" ;
576		ok 153, $hash{"green"} eq "ho" ;
577		ok 154, $hash{"blue"} eq "se" ;
	576	ok $hash{"red"} eq "bo" ;
	577	ok $hash{"green"} eq "ho" ;
	578	ok $hash{"blue"} eq "se" ;
578	579
579	580	# do a partial get, off end of data
580	581	$db->partial_set(3,2) ;
581		ok 155, $hash{"red"} eq "t" ;
582		ok 156, $hash{"green"} eq "se" ;
583		ok 157, $hash{"blue"} eq "" ;
	582	ok $hash{"red"} eq "t" ;
	583	ok $hash{"green"} eq "se" ;
	584	ok $hash{"blue"} eq "" ;
584	585
585	586	# switch of partial mode
586	587	$db->partial_clear() ;
587		ok 158, $hash{"red"} eq "boat" ;
588		ok 159, $hash{"green"} eq "house" ;
589		ok 160, $hash{"blue"} eq "sea" ;
	588	ok $hash{"red"} eq "boat" ;
	589	ok $hash{"green"} eq "house" ;
	590	ok $hash{"blue"} eq "sea" ;
590	591
591	592	# now partial put
592	593	$db->partial_set(0,2) ;
593		ok 161, $hash{"red"} = "" ;
594		ok 162, $hash{"green"} = "AB" ;
595		ok 163, $hash{"blue"} = "XYZ" ;
596		ok 164, $hash{"new"} = "KLM" ;
	594	ok $hash{"red"} = "" ;
	595	ok $hash{"green"} = "AB" ;
	596	ok $hash{"blue"} = "XYZ" ;
	597	ok $hash{"new"} = "KLM" ;
597	598
598	599	$db->partial_clear() ;
599		ok 165, $hash{"red"} eq "at" ;
600		ok 166, $hash{"green"} eq "ABuse" ;
601		ok 167, $hash{"blue"} eq "XYZa" ;
602		ok 168, $hash{"new"} eq "KLM" ;
	600	ok $hash{"red"} eq "at" ;
	601	ok $hash{"green"} eq "ABuse" ;
	602	ok $hash{"blue"} eq "XYZa" ;
	603	ok $hash{"new"} eq "KLM" ;
603	604
604	605	# now partial put
605	606	$db->partial_set(3,2) ;
606		ok 169, $hash{"red"} = "PPP" ;
607		ok 170, $hash{"green"} = "Q" ;
608		ok 171, $hash{"blue"} = "XYZ" ;
609		ok 172, $hash{"new"} = "TU" ;
	607	ok $hash{"red"} = "PPP" ;
	608	ok $hash{"green"} = "Q" ;
	609	ok $hash{"blue"} = "XYZ" ;
	610	ok $hash{"new"} = "TU" ;
610	611
611	612	$db->partial_clear() ;
612		ok 173, $hash{"red"} eq "at\0PPP" ;
613		ok 174, $hash{"green"} eq "ABuQ" ;
614		ok 175, $hash{"blue"} eq "XYZXYZ" ;
615		ok 176, $hash{"new"} eq "KLMTU" ;
	613	ok $hash{"red"} eq "at\0PPP" ;
	614	ok $hash{"green"} eq "ABuQ" ;
	615	ok $hash{"blue"} eq "XYZXYZ" ;
	616	ok $hash{"new"} eq "KLMTU" ;
616	617	}
617	618
618	619	{

623	624	my $value ;
624	625
625	626	my $home = "./fred" ;
626		ok 177, my $lexD = new LexDir($home) ;
627		ok 178, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	627	ok my $lexD = new LexDir($home) ;
	628	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
628	629	-Flags => DB_CREATE\|DB_INIT_TXN\|
629	630	DB_INIT_MPOOL\|DB_INIT_LOCK ;
630		ok 179, my $txn = $env->txn_begin() ;
631		ok 180, my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
	631	ok my $txn = $env->txn_begin() ;
	632	ok my $db1 = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
632	633	-Flags => DB_CREATE ,
633	634	-Env => $env,
634	635	-Txn => $txn ;
635	636
636		ok 181, (my $Z = $txn->txn_commit()) == 0 ;
637		ok 182, $txn = $env->txn_begin() ;
	637	ok ((my $Z = $txn->txn_commit()) == 0) ;
	638	ok $txn = $env->txn_begin() ;
638	639	$db1->Txn($txn);
639	640
640	641	# create some data

648	649	while (my ($k, $v) = each %data) {
649	650	$ret += $db1->db_put($k, $v) ;
650	651	}
651		ok 183, $ret == 0 ;
	652	ok $ret == 0 ;
652	653
653	654	# should be able to see all the records
654	655
655		ok 184, my $cursor = $db1->db_cursor() ;
	656	ok my $cursor = $db1->db_cursor() ;
656	657	my ($k, $v) = ("", "") ;
657	658	my $count = 0 ;
658	659	# sequence forwards
659	660	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
660	661	++ $count ;
661	662	}
662		ok 185, $count == 3 ;
	663	ok $count == 3 ;
663	664	undef $cursor ;
664	665
665	666	# now abort the transaction
666		#ok 151, $txn->txn_abort() == 0 ;
667		ok 186, ($Z = $txn->txn_abort()) == 0 ;
	667	#ok $txn->txn_abort() == 0 ;
	668	ok (($Z = $txn->txn_abort()) == 0) ;
668	669
669	670	# there shouldn't be any records in the database
670	671	$count = 0 ;
671	672	# sequence forwards
672		ok 187, $cursor = $db1->db_cursor() ;
	673	ok $cursor = $db1->db_cursor() ;
673	674	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
674	675	++ $count ;
675	676	}
676		ok 188, $count == 0 ;
	677	ok $count == 0 ;
677	678
678	679	undef $txn ;
679	680	undef $cursor ;

687	688
688	689	my $lex = new LexFile $Dfile ;
689	690	my %hash ;
690		ok 189, my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
	691	ok my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
691	692	-Property => DB_DUP,
692	693	-Flags => DB_CREATE ;
693	694

698	699	$hash{'Wall'} = 'Brick' ;
699	700	$hash{'mouse'} = 'mickey' ;
700	701
701		ok 190, keys %hash == 6 ;
	702	ok keys %hash == 6 ;
702	703
703	704	# create a cursor
704		ok 191, my $cursor = $db->db_cursor() ;
	705	ok my $cursor = $db->db_cursor() ;
705	706
706	707	my $key = "Wall" ;
707	708	my $value ;
708		ok 192, $cursor->c_get($key, $value, DB_SET) == 0 ;
709		ok 193, $key eq "Wall" && $value eq "Larry" ;
710		ok 194, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
711		ok 195, $key eq "Wall" && $value eq "Stone" ;
712		ok 196, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
713		ok 197, $key eq "Wall" && $value eq "Brick" ;
714		ok 198, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
715		ok 199, $key eq "Wall" && $value eq "Brick" ;
	709	ok $cursor->c_get($key, $value, DB_SET) == 0 ;
	710	ok $key eq "Wall" && $value eq "Larry" ;
	711	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	712	ok $key eq "Wall" && $value eq "Stone" ;
	713	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	714	ok $key eq "Wall" && $value eq "Brick" ;
	715	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	716	ok $key eq "Wall" && $value eq "Brick" ;
716	717
717	718	#my $ref = $db->db_stat() ;
718		#ok 200, ($ref->{bt_flags} \| DB_DUP) == DB_DUP ;
	719	#ok ($ref->{bt_flags} \| DB_DUP) == DB_DUP ;
719	720	#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
720	721
721	722	undef $db ;

731	732	my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
732	733	my %hash ;
733	734	my ($k, $v) ;
734		ok 200, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	735	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
735	736	-Flags => DB_CREATE,
736	737	-Minkey =>3 ,
737	738	-Pagesize => 2 **12
738	739	;
739	740
740	741	my $ref = $db->db_stat() ;
741		ok 201, $ref->{$recs} == 0;
742		ok 202, $ref->{'bt_minkey'} == 3;
743		ok 203, $ref->{'bt_pagesize'} == 2 ** 12;
	742	ok $ref->{$recs} == 0;
	743	ok $ref->{'bt_minkey'} == 3;
	744	ok $ref->{'bt_pagesize'} == 2 ** 12;
744	745
745	746	# create some data
746	747	my %data = (

753	754	while (($k, $v) = each %data) {
754	755	$ret += $db->db_put($k, $v) ;
755	756	}
756		ok 204, $ret == 0 ;
	757	ok $ret == 0 ;
757	758
758	759	$ref = $db->db_stat() ;
759		ok 205, $ref->{$recs} == 3;
	760	ok $ref->{$recs} == 3;
760	761	}
761	762
762	763	{

805	806
806	807	close FILE ;
807	808
	809	use Test::More;
808	810	BEGIN { push @INC, '.'; }
809	811	eval 'use SubDB ; ';
810		main::ok 206, $@ eq "" ;
	812	ok $@ eq "" ;
811	813	my %h ;
812	814	my $X ;
813	815	eval '

816	818	-Mode => 0640 );
817	819	' ;
818	820
819		main::ok 207, $@ eq "" && $X ;
	821	ok $@ eq "" && $X ;
820	822
821	823	my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
822		main::ok 208, $@ eq "" ;
823		main::ok 209, $ret == 7 ;
	824	ok $@ eq "" ;
	825	ok $ret == 7 ;
824	826
825	827	my $value = 0;
826	828	$ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
827		main::ok 210, $@ eq "" ;
828		main::ok 211, $ret == 10 ;
	829	ok $@ eq "" ;
	830	ok $ret == 10 ;
829	831
830	832	$ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
831		main::ok 212, $@ eq "" ;
832		main::ok 213, $ret == 1 ;
	833	ok $@ eq "" ;
	834	ok $ret == 1 ;
833	835
834	836	$ret = eval '$X->A_new_method("joe") ' ;
835		main::ok 214, $@ eq "" ;
836		main::ok 215, $ret eq "[[10]]" ;
	837	ok $@ eq "" ;
	838	ok $ret eq "[[10]]" ;
837	839
838	840	undef $X;
839	841	untie %h;

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

868	870	$ret += $db->db_put($_, $ix) ;
869	871	++ $ix ;
870	872	}
871		ok 217, $ret == 0 ;
	873	ok $ret == 0 ;
872	874
873	875	# db_get & DB_SET_RECNO
874	876	$k = 1 ;
875		ok 218, $db->db_get($k, $v, DB_SET_RECNO) == 0;
876		ok 219, $k eq "B one" && $v == 1 ;
	877	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	878	ok $k eq "B one" && $v == 1 ;
877	879
878	880	$k = 3 ;
879		ok 220, $db->db_get($k, $v, DB_SET_RECNO) == 0;
880		ok 221, $k eq "D three" && $v == 3 ;
	881	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	882	ok $k eq "D three" && $v == 3 ;
881	883
882	884	$k = 4 ;
883		ok 222, $db->db_get($k, $v, DB_SET_RECNO) == 0;
884		ok 223, $k eq "E four" && $v == 4 ;
	885	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	886	ok $k eq "E four" && $v == 4 ;
885	887
886	888	$k = 0 ;
887		ok 224, $db->db_get($k, $v, DB_SET_RECNO) == 0;
888		ok 225, $k eq "A zero" && $v == 0 ;
	889	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	890	ok $k eq "A zero" && $v == 0 ;
889	891
890	892	# cursor & DB_SET_RECNO
891	893
892	894	# create the cursor
893		ok 226, my $cursor = $db->db_cursor() ;
	895	ok my $cursor = $db->db_cursor() ;
894	896
895	897	$k = 2 ;
896		ok 227, $db->db_get($k, $v, DB_SET_RECNO) == 0;
897		ok 228, $k eq "C two" && $v == 2 ;
	898	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	899	ok $k eq "C two" && $v == 2 ;
898	900
899	901	$k = 0 ;
900		ok 229, $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
901		ok 230, $k eq "A zero" && $v == 0 ;
	902	ok $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
	903	ok $k eq "A zero" && $v == 0 ;
902	904
903	905	$k = 3 ;
904		ok 231, $db->db_get($k, $v, DB_SET_RECNO) == 0;
905		ok 232, $k eq "D three" && $v == 3 ;
	906	ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
	907	ok $k eq "D three" && $v == 3 ;
906	908
907	909	# cursor & DB_GET_RECNO
908		ok 233, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
909		ok 234, $k eq "A zero" && $v == 0 ;
910		ok 235, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
911		ok 236, $v == 0 ;
912
913		ok 237, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
914		ok 238, $k eq "B one" && $v == 1 ;
915		ok 239, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
916		ok 240, $v == 1 ;
917
918		ok 241, $cursor->c_get($k, $v, DB_LAST) == 0 ;
919		ok 242, $k eq "E four" && $v == 4 ;
920		ok 243, $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
921		ok 244, $v == 4 ;
922
923		}
924
	910	ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
	911	ok $k eq "A zero" && $v == 0 ;
	912	ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
	913	ok $v == 0 ;
	914
	915	ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
	916	ok $k eq "B one" && $v == 1 ;
	917	ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
	918	ok $v == 1 ;
	919
	920	ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
	921	ok $k eq "E four" && $v == 4 ;
	922	ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
	923	ok $v == 4 ;
	924
	925	}
	926

+20

-21

t/cds.t less more

6	6
7	7	use BerkeleyDB;
8	8	use util ;
9
10		BEGIN
11		{
12		if ($BerkeleyDB::db_version < 2) {
13		print "1..0 # Skip: this needs Berkeley DB 2.x.x or better\n" ;
14		exit 0 ;
15		}
16		}
	9	use Test::More;
17	10
18	11
19	12
20		print "1..12\n";
	13	BEGIN {
	14	plan(skip_all => "this needs BerkeleyDB 2.x or better" )
	15	if $BerkeleyDB::db_version < 2;
	16
	17	plan tests => 12;
	18	}
	19
21	20
22	21	my $Dfile = "dbhash.tmp";
23	22	unlink $Dfile;

30	29	my $lex = new LexFile $Dfile ;
31	30
32	31	my $home = "./fred" ;
33		ok 1, my $lexD = new LexDir($home) ;
	32	ok my $lexD = new LexDir($home) ;
34	33
35		ok 2, my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
	34	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,
36	35	-Home => $home, @StdErrFile ;
37	36
38		ok 3, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	37	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
39	38	-Env => $env,
40	39	-Flags => DB_CREATE ;
41	40
42		ok 4, ! $env->cds_enabled() ;
43		ok 5, ! $db->cds_enabled() ;
	41	ok ! $env->cds_enabled() ;
	42	ok ! $db->cds_enabled() ;
44	43
45	44	eval { $db->cds_lock() };
46		ok 6, $@ =~ /CDS not enabled for this database/;
	45	ok $@ =~ /CDS not enabled for this database/;
47	46
48	47	undef $db;
49	48	undef $env ;

53	52	my $lex = new LexFile $Dfile ;
54	53
55	54	my $home = "./fred" ;
56		ok 7, my $lexD = new LexDir($home) ;
	55	ok my $lexD = new LexDir($home) ;
57	56
58		ok 8, my $env = new BerkeleyDB::Env -Flags => DB_INIT_CDB\|DB_CREATE\|DB_INIT_MPOOL,
	57	ok my $env = new BerkeleyDB::Env -Flags => DB_INIT_CDB\|DB_CREATE\|DB_INIT_MPOOL,
59	58	-Home => $home, @StdErrFile ;
60	59
61		ok 9, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	60	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
62	61	-Env => $env,
63	62	-Flags => DB_CREATE ;
64	63
65		ok 10, $env->cds_enabled() ;
66		ok 11, $db->cds_enabled() ;
	64	ok $env->cds_enabled() ;
	65	ok $db->cds_enabled() ;
67	66
68	67	my $cds = $db->cds_lock() ;
69		ok 12, $cds ;
	68	ok $cds ;
70	69
71	70	undef $db;
72	71	undef $env ;

+20

-22

t/db-3.0.t less more

7	7	use BerkeleyDB;
8	8	use util ;
9	9
10		BEGIN
11		{
12		if ($BerkeleyDB::db_version < 3) {
13		print "1..0 # Skip: this needs Berkeley DB 3.x or better\n" ;
14		exit 0 ;
15		}
16		}
	10	use Test::More ;
17	11
18		print "1..14\n";
	12	BEGIN {
	13	plan(skip_all => "this needs BerkeleyDB 3.x or better" )
	14	if $BerkeleyDB::db_version < 3;
19	15
	16	plan tests => 14;
	17	}
20	18
21	19	my $Dfile = "dbhash.tmp";
22	20

26	24	# set_mutexlocks
27	25
28	26	my $home = "./fred" ;
29		ok 1, my $lexD = new LexDir($home) ;
	27	ok my $lexD = new LexDir($home) ;
30	28	chdir "./fred" ;
31		ok 2, my $env = new BerkeleyDB::Env -Flags => DB_CREATE, @StdErrFile ;
32		ok 3, $env->set_mutexlocks(0) == 0 ;
	29	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE, @StdErrFile ;
	30	ok $env->set_mutexlocks(0) == 0 ;
33	31	chdir ".." ;
34	32	undef $env ;
35	33	}

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

58	56	my $v = shift @data ;
59	57	$ret += $db->db_put($k, $v) ;
60	58	}
61		ok 5, $ret == 0 ;
	59	ok $ret == 0 ;
62	60
63	61	# create a cursor
64		ok 6, my $cursor = $db->db_cursor() ;
	62	ok my $cursor = $db->db_cursor() ;
65	63
66	64	# point to a specific k/v pair
67	65	$k = "green" ;
68		ok 7, $cursor->c_get($k, $v, DB_SET) == 0 ;
69		ok 8, $v eq "house" ;
	66	ok $cursor->c_get($k, $v, DB_SET) == 0 ;
	67	ok $v eq "house" ;
70	68
71	69	# duplicate the cursor
72	70	my $dup_cursor = $cursor->c_dup(DB_POSITION);
73		ok 9, $dup_cursor ;
	71	ok $dup_cursor ;
74	72
75	73	# move original cursor off green/house
76	74	my $s = $cursor->c_get($k, $v, DB_NEXT) ;
77		ok 10, $k ne "green" ;
78		ok 11, $v ne "house" ;
	75	ok $k ne "green" ;
	76	ok $v ne "house" ;
79	77
80	78	# duplicate cursor should still be on green/house
81		ok 12, $dup_cursor->c_get($k, $v, DB_CURRENT) == 0;
82		ok 13, $k eq "green" ;
83		ok 14, $v eq "house" ;
	79	ok $dup_cursor->c_get($k, $v, DB_CURRENT) == 0;
	80	ok $k eq "green" ;
	81	ok $v eq "house" ;
84	82
85	83	}
86	84

-1

t/db-3.1.t less more

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

+12

-14

t/db-3.2.t less more

7	7	use BerkeleyDB;
8	8	use util ;
9	9
10		BEGIN
11		{
12		if ($BerkeleyDB::db_version < 3.2) {
13		print "1..0 # Skip: this needs Berkeley DB 3.2.x or better\n" ;
14		exit 0 ;
15		}
16		}
	10	use Test::More ;
17	11
18		print "1..6\n";
	12	BEGIN {
	13	plan(skip_all => "this needs BerkeleyDB 3.2.x or better" )
	14	if $BerkeleyDB::db_version < 3.2;
19	15
	16	plan tests => 6;
	17	}
20	18
21	19	my $Dfile = "dbhash.tmp";
22	20	my $Dfile2 = "dbhash2.tmp";

30	28	{
31	29	# set_q_extentsize
32	30
33		ok 1, 1 ;
	31	ok 1 ;
34	32	}
35	33
36	34	{
37	35	# env->set_flags
38	36
39	37	my $home = "./fred" ;
40		ok 2, my $lexD = new LexDir($home) ;
41		ok 3, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	38	ok my $lexD = new LexDir($home) ;
	39	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
42	40	-Flags => DB_CREATE ,
43	41	-SetFlags => DB_NOMMAP ;
44	42

49	47	# env->set_flags
50	48
51	49	my $home = "./fred" ;
52		ok 4, my $lexD = new LexDir($home) ;
53		ok 5, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	50	ok my $lexD = new LexDir($home) ;
	51	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
54	52	-Flags => DB_CREATE ;
55		ok 6, ! $env->set_flags(DB_NOMMAP, 1);
	53	ok ! $env->set_flags(DB_NOMMAP, 1);
56	54
57	55	undef $env ;
58	56	}

+153

-155

t/db-3.3.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		BEGIN
11		{
12		if ($BerkeleyDB::db_version < 3.3) {
13		print "1..0 # Skip: this needs Berkeley DB 3.3.x or better\n" ;
14		exit 0 ;
15		}
16		}
	9	use Test::More;
	10
	11	BEGIN {
	12	plan(skip_all => "this needs BerkeleyDB 3.3.x or better" )
	13	if $BerkeleyDB::db_version < 3.3;
	14
	15	plan tests => 130;
	16	}
17	17
18	18	umask(0);
19
20		print "1..130\n";
21	19
22	20	{
23	21	# db->truncate

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

40	38	while (($k, $v) = each %data) {
41	39	$ret += $db->db_put($k, $v) ;
42	40	}
43		ok 2, $ret == 0 ;
	41	ok $ret == 0 ;
44	42
45	43	# check there are three records
46		ok 3, countRecords($db) == 3 ;
	44	is countRecords($db), 3 ;
47	45
48	46	# now truncate the database
49	47	my $count = 0;
50		ok 4, $db->truncate($count) == 0 ;
51
52		ok 5, $count == 3 ;
53		ok 6, countRecords($db) == 0 ;
	48	ok $db->truncate($count) == 0 ;
	49
	50	is $count, 3 ;
	51	ok countRecords($db) == 0 ;
54	52
55	53	}
56	54

74	72	my ($k, $v, $pk) = ('','','');
75	73
76	74	# create primary database
77		ok 7, my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	75	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
78	76	-Flags => DB_CREATE ;
79	77
80	78	# create secondary database
81		ok 8, my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	79	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
82	80	-Flags => DB_CREATE ;
83	81
84	82	# associate primary with secondary
85		ok 9, $primary->associate($secondary, \&sec_key) == 0;
	83	ok $primary->associate($secondary, \&sec_key) == 0;
86	84
87	85	# add data to the primary
88	86	my %data = (

97	95	#print "put $r $BerkeleyDB::Error\n";
98	96	$ret += $r;
99	97	}
100		ok 10, $ret == 0 ;
	98	ok $ret == 0 ;
101	99
102	100	# check the records in the secondary
103		ok 11, countRecords($secondary) == 3 ;
104
105		ok 12, $secondary->db_get("house", $v) == 0;
106		ok 13, $v eq "house";
107
108		ok 14, $secondary->db_get("sea", $v) == 0;
109		ok 15, $v eq "sea";
110
111		ok 16, $secondary->db_get("flag", $v) == 0;
112		ok 17, $v eq "flag";
	101	is countRecords($secondary), 3 ;
	102
	103	ok $secondary->db_get("house", $v) == 0;
	104	is $v, "house";
	105
	106	ok $secondary->db_get("sea", $v) == 0;
	107	is $v, "sea";
	108
	109	ok $secondary->db_get("flag", $v) == 0;
	110	is $v, "flag";
113	111
114	112	# pget to primary database is illegal
115		ok 18, $primary->db_pget('red', $pk, $v) != 0 ;
	113	ok $primary->db_pget('red', $pk, $v) != 0 ;
116	114
117	115	# pget to secondary database is ok
118		ok 19, $secondary->db_pget('house', $pk, $v) == 0 ;
119		ok 20, $pk eq 'green';
120		ok 21, $v eq 'house';
121
122		ok 22, my $p_cursor = $primary->db_cursor();
123		ok 23, my $s_cursor = $secondary->db_cursor();
	116	ok $secondary->db_pget('house', $pk, $v) == 0 ;
	117	is $pk, 'green';
	118	is $v, 'house';
	119
	120	ok my $p_cursor = $primary->db_cursor();
	121	ok my $s_cursor = $secondary->db_cursor();
124	122
125	123	# c_get from primary
126	124	$k = 'green';
127		ok 24, $p_cursor->c_get($k, $v, DB_SET) == 0;
128		ok 25, $k eq 'green';
129		ok 26, $v eq 'house';
	125	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
	126	is $k, 'green';
	127	is $v, 'house';
130	128
131	129	# c_get from secondary
132	130	$k = 'sea';
133		ok 27, $s_cursor->c_get($k, $v, DB_SET) == 0;
134		ok 28, $k eq 'sea';
135		ok 29, $v eq 'sea';
	131	ok $s_cursor->c_get($k, $v, DB_SET) == 0;
	132	is $k, 'sea';
	133	is $v, 'sea';
136	134
137	135	# c_pget from primary database should fail
138	136	$k = 1;
139		ok 30, $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
	137	ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
140	138
141	139	# c_pget from secondary database
142	140	$k = 'flag';
143		ok 31, $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
144		ok 32, $k eq 'flag';
145		ok 33, $pk eq 'red';
146		ok 34, $v eq 'flag';
	141	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
	142	is $k, 'flag';
	143	is $pk, 'red';
	144	is $v, 'flag';
147	145
148	146	# check put to secondary is illegal
149		ok 35, $secondary->db_put("tom", "dick") != 0;
150		ok 36, countRecords($secondary) == 3 ;
	147	ok $secondary->db_put("tom", "dick") != 0;
	148	is countRecords($secondary), 3 ;
151	149
152	150	# delete from primary
153		ok 37, $primary->db_del("green") == 0 ;
154		ok 38, countRecords($primary) == 2 ;
	151	ok $primary->db_del("green") == 0 ;
	152	is countRecords($primary), 2 ;
155	153
156	154	# check has been deleted in secondary
157		ok 39, $secondary->db_get("house", $v) != 0;
158		ok 40, countRecords($secondary) == 2 ;
	155	ok $secondary->db_get("house", $v) != 0;
	156	is countRecords($secondary), 2 ;
159	157
160	158	# delete from secondary
161		ok 41, $secondary->db_del('flag') == 0 ;
162		ok 42, countRecords($secondary) == 1 ;
	159	ok $secondary->db_del('flag') == 0 ;
	160	is countRecords($secondary), 1 ;
163	161
164	162
165	163	# check deleted from primary
166		ok 43, $primary->db_get("red", $v) != 0;
167		ok 44, countRecords($primary) == 1 ;
	164	ok $primary->db_get("red", $v) != 0;
	165	is countRecords($primary), 1 ;
168	166
169	167	}
170	168

195	193	my ($k, $v, $pk) = ('','','');
196	194
197	195	# create primary database
198		ok 45, my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
	196	ok my $primary = new BerkeleyDB::Btree -Filename => $Dfile1,
199	197	-Compare => sub { return $_[0] cmp $_[1]},
200	198	-Flags => DB_CREATE ;
201	199
202	200	# create secondary database
203		ok 46, my $secondary = new BerkeleyDB::Btree -Filename => $Dfile2,
	201	ok my $secondary = new BerkeleyDB::Btree -Filename => $Dfile2,
204	202	-Compare => sub { return $_[0] <=> $_[1]},
205	203	-Property => DB_DUP,
206	204	-Flags => DB_CREATE ;
207	205
208	206	# associate primary with secondary
209		ok 47, $primary->associate($secondary, \&sec_key2) == 0;
	207	ok $primary->associate($secondary, \&sec_key2) == 0;
210	208
211	209	# add data to the primary
212	210	my %data = (

222	220	#print "put [$r] $BerkeleyDB::Error\n";
223	221	$ret += $r;
224	222	}
225		ok 48, $ret == 0 ;
	223	ok $ret == 0 ;
226	224	#print "ret $ret\n";
227	225
228	226	#print "Primary\n" ; dumpdb($primary) ;
229	227	#print "Secondary\n" ; dumpdb($secondary) ;
230	228
231	229	# check the records in the secondary
232		ok 49, countRecords($secondary) == 4 ;
	230	is countRecords($secondary), 4 ;
233	231
234	232	my $p_data = joinkeys($primary, " ");
235	233	#print "primary [$p_data]\n" ;
236		ok 50, $p_data eq join " ", sort { $a cmp $b } keys %data ;
	234	is $p_data, join " ", sort { $a cmp $b } keys %data ;
237	235	my $s_data = joinkeys($secondary, " ");
238	236	#print "secondary [$s_data]\n" ;
239		ok 51, $s_data eq join " ", sort { $a <=> $b } map { length } values %data ;
	237	is $s_data, join " ", sort { $a <=> $b } map { length } values %data ;
240	238
241	239	}
242	240

260	258	my ($k, $v, $pk) = ('','','');
261	259
262	260	# create primary database
263		ok 52, my $primary = new BerkeleyDB::Recno -Filename => $Dfile1,
	261	ok my $primary = new BerkeleyDB::Recno -Filename => $Dfile1,
264	262	-Flags => DB_CREATE ;
265	263
266	264	# create secondary database
267		ok 53, my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	265	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
268	266	-Flags => DB_CREATE ;
269	267
270	268	# associate primary with secondary
271		ok 54, $primary->associate($secondary, \&sec_key3) == 0;
	269	ok $primary->associate($secondary, \&sec_key3) == 0;
272	270
273	271	# add data to the primary
274	272	my %data = (

283	281	#print "put $r $BerkeleyDB::Error\n";
284	282	$ret += $r;
285	283	}
286		ok 55, $ret == 0 ;
	284	ok $ret == 0 ;
287	285
288	286	# check the records in the secondary
289		ok 56, countRecords($secondary) == 3 ;
290
291		ok 57, $secondary->db_get("flag", $v) == 0;
292		ok 58, $v eq "flag";
293
294		ok 59, $secondary->db_get("house", $v) == 0;
295		ok 60, $v eq "house";
296
297		ok 61, $secondary->db_get("sea", $v) == 0;
298		ok 62, $v eq "sea" ;
	287	is countRecords($secondary), 3 ;
	288
	289	ok $secondary->db_get("flag", $v) == 0;
	290	is $v, "flag";
	291
	292	ok $secondary->db_get("house", $v) == 0;
	293	is $v, "house";
	294
	295	ok $secondary->db_get("sea", $v) == 0;
	296	is $v, "sea" ;
299	297
300	298	# pget to primary database is illegal
301		ok 63, $primary->db_pget(0, $pk, $v) != 0 ;
	299	ok $primary->db_pget(0, $pk, $v) != 0 ;
302	300
303	301	# pget to secondary database is ok
304		ok 64, $secondary->db_pget('house', $pk, $v) == 0 ;
305		ok 65, $pk == 1 ;
306		ok 66, $v eq 'house';
307
308		ok 67, my $p_cursor = $primary->db_cursor();
309		ok 68, my $s_cursor = $secondary->db_cursor();
	302	ok $secondary->db_pget('house', $pk, $v) == 0 ;
	303	is $pk, 1 ;
	304	is $v, 'house';
	305
	306	ok my $p_cursor = $primary->db_cursor();
	307	ok my $s_cursor = $secondary->db_cursor();
310	308
311	309	# c_get from primary
312	310	$k = 1;
313		ok 69, $p_cursor->c_get($k, $v, DB_SET) == 0;
314		ok 70, $k == 1;
315		ok 71, $v eq 'house';
	311	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
	312	is $k, 1;
	313	is $v, 'house';
316	314
317	315	# c_get from secondary
318	316	$k = 'sea';
319		ok 72, $s_cursor->c_get($k, $v, DB_SET) == 0;
320		ok 73, $k eq 'sea'
	317	ok $s_cursor->c_get($k, $v, DB_SET) == 0;
	318	is $k, 'sea'
321	319	or warn "# key [$k]\n";
322		ok 74, $v eq 'sea';
	320	is $v, 'sea';
323	321
324	322	# c_pget from primary database should fail
325	323	$k = 1;
326		ok 75, $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
	324	ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
327	325
328	326	# c_pget from secondary database
329	327	$k = 'sea';
330		ok 76, $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
331		ok 77, $k eq 'sea' ;
332		ok 78, $pk == 2 ;
333		ok 79, $v eq 'sea';
	328	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
	329	is $k, 'sea' ;
	330	is $pk, 2 ;
	331	is $v, 'sea';
334	332
335	333	# check put to secondary is illegal
336		ok 80, $secondary->db_put("tom", "dick") != 0;
337		ok 81, countRecords($secondary) == 3 ;
	334	ok $secondary->db_put("tom", "dick") != 0;
	335	is countRecords($secondary), 3 ;
338	336
339	337	# delete from primary
340		ok 82, $primary->db_del(2) == 0 ;
341		ok 83, countRecords($primary) == 2 ;
	338	ok $primary->db_del(2) == 0 ;
	339	is countRecords($primary), 2 ;
342	340
343	341	# check has been deleted in secondary
344		ok 84, $secondary->db_get("sea", $v) != 0;
345		ok 85, countRecords($secondary) == 2 ;
	342	ok $secondary->db_get("sea", $v) != 0;
	343	is countRecords($secondary), 2 ;
346	344
347	345	# delete from secondary
348		ok 86, $secondary->db_del('flag') == 0 ;
349		ok 87, countRecords($secondary) == 1 ;
	346	ok $secondary->db_del('flag') == 0 ;
	347	is countRecords($secondary), 1 ;
350	348
351	349
352	350	# check deleted from primary
353		ok 88, $primary->db_get(0, $v) != 0;
354		ok 89, countRecords($primary) == 1 ;
	351	ok $primary->db_get(0, $v) != 0;
	352	is countRecords($primary), 1 ;
355	353
356	354	}
357	355

375	373	my ($k, $v, $pk) = ('','','');
376	374
377	375	# create primary database
378		ok 90, my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	376	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
379	377	-Flags => DB_CREATE ;
380	378
381	379	# create secondary database
382		ok 91, my $secondary = new BerkeleyDB::Recno -Filename => $Dfile2,
	380	ok my $secondary = new BerkeleyDB::Recno -Filename => $Dfile2,
383	381	#-Property => DB_DUP,
384	382	-Flags => DB_CREATE ;
385	383
386	384	# associate primary with secondary
387		ok 92, $primary->associate($secondary, \&sec_key4) == 0;
	385	ok $primary->associate($secondary, \&sec_key4) == 0;
388	386
389	387	# add data to the primary
390	388	my %data = (

399	397	#print "put $r $BerkeleyDB::Error\n";
400	398	$ret += $r;
401	399	}
402		ok 93, $ret == 0 ;
	400	ok $ret == 0 ;
403	401
404	402	# check the records in the secondary
405		ok 94, countRecords($secondary) == 3 ;
406
407		ok 95, $secondary->db_get(0, $v) != 0;
408		ok 96, $secondary->db_get(1, $v) != 0;
409		ok 97, $secondary->db_get(2, $v) != 0;
410		ok 98, $secondary->db_get(3, $v) == 0;
411		ok 99, $v eq "sea";
412
413		ok 100, $secondary->db_get(4, $v) == 0;
414		ok 101, $v eq "flag";
415
416		ok 102, $secondary->db_get(5, $v) == 0;
417		ok 103, $v eq "house";
	403	is countRecords($secondary), 3 ;
	404
	405	ok $secondary->db_get(0, $v) != 0;
	406	ok $secondary->db_get(1, $v) != 0;
	407	ok $secondary->db_get(2, $v) != 0;
	408	ok $secondary->db_get(3, $v) == 0;
	409	ok $v eq "sea";
	410
	411	ok $secondary->db_get(4, $v) == 0;
	412	is $v, "flag";
	413
	414	ok $secondary->db_get(5, $v) == 0;
	415	is $v, "house";
418	416
419	417	# pget to primary database is illegal
420		ok 104, $primary->db_pget(0, $pk, $v) != 0 ;
	418	ok $primary->db_pget(0, $pk, $v) != 0 ;
421	419
422	420	# pget to secondary database is ok
423		ok 105, $secondary->db_pget(4, $pk, $v) == 0 ;
424		ok 106, $pk eq 'red'
	421	ok $secondary->db_pget(4, $pk, $v) == 0 ;
	422	is $pk, 'red'
425	423	or warn "# $pk\n";;
426		ok 107, $v eq 'flag';
427
428		ok 108, my $p_cursor = $primary->db_cursor();
429		ok 109, my $s_cursor = $secondary->db_cursor();
	424	is $v, 'flag';
	425
	426	ok my $p_cursor = $primary->db_cursor();
	427	ok my $s_cursor = $secondary->db_cursor();
430	428
431	429	# c_get from primary
432	430	$k = 'green';
433		ok 110, $p_cursor->c_get($k, $v, DB_SET) == 0;
434		ok 111, $k eq 'green';
435		ok 112, $v eq 'house';
	431	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
	432	is $k, 'green';
	433	is $v, 'house';
436	434
437	435	# c_get from secondary
438	436	$k = 3;
439		ok 113, $s_cursor->c_get($k, $v, DB_SET) == 0;
440		ok 114, $k == 3 ;
441		ok 115, $v eq 'sea';
	437	ok $s_cursor->c_get($k, $v, DB_SET) == 0;
	438	is $k, 3 ;
	439	is $v, 'sea';
442	440
443	441	# c_pget from primary database should fail
444	442	$k = 1;
445		ok 116, $p_cursor->c_pget($k, $pk, $v, DB_SET) != 0;
	443	ok $p_cursor->c_pget($k, $pk, $v, DB_SET) != 0;
446	444
447	445	# c_pget from secondary database
448	446	$k = 5;
449		ok 117, $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
450		ok 118, $k == 5 ;
451		ok 119, $pk eq 'green';
452		ok 120, $v eq 'house';
	447	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
	448	is $k, 5 ;
	449	is $pk, 'green';
	450	is $v, 'house';
453	451
454	452	# check put to secondary is illegal
455		ok 121, $secondary->db_put(77, "dick") != 0;
456		ok 122, countRecords($secondary) == 3 ;
	453	ok $secondary->db_put(77, "dick") != 0;
	454	is countRecords($secondary), 3 ;
457	455
458	456	# delete from primary
459		ok 123, $primary->db_del("green") == 0 ;
460		ok 124, countRecords($primary) == 2 ;
	457	ok $primary->db_del("green") == 0 ;
	458	is countRecords($primary), 2 ;
461	459
462	460	# check has been deleted in secondary
463		ok 125, $secondary->db_get(5, $v) != 0;
464		ok 126, countRecords($secondary) == 2 ;
	461	ok $secondary->db_get(5, $v) != 0;
	462	is countRecords($secondary), 2 ;
465	463
466	464	# delete from secondary
467		ok 127, $secondary->db_del(4) == 0 ;
468		ok 128, countRecords($secondary) == 1 ;
	465	ok $secondary->db_del(4) == 0 ;
	466	is countRecords($secondary), 1 ;
469	467
470	468
471	469	# check deleted from primary
472		ok 129, $primary->db_get("red", $v) != 0;
473		ok 130, countRecords($primary) == 1 ;
474
475		}
	470	ok $primary->db_get("red", $v) != 0;
	471	is countRecords($primary), 1 ;
	472
	473	}

-1

t/db-4.4.t less more

4	4	use lib 't' ;
5	5	use BerkeleyDB;
6	6	use Test::More ;
7		use util (1);
	7	use util ;
8	8
9	9	plan(skip_all => "this needs Berkeley DB 4.4.x or better\n" )
10	10	if $BerkeleyDB::db_version < 4.4;

+234

-0

t/db-4.6.t less more

	0	#!./perl -w
	1
	2
	3	use strict ;
	4
	5
	6	use lib 't' ;
	7	use BerkeleyDB;
	8	use util ;
	9
	10	use Test::More ;
	11
	12	BEGIN {
	13	plan(skip_all => "this needs BerkeleyDB 4.6.x or better" )
	14	if $BerkeleyDB::db_version < 4.6;
	15
	16	plan tests => 63;
	17	}
	18
	19	umask(0);
	20
	21	{
	22	# db->associate -- secondary keys returning DB_DBT_MULTIPLE
	23
	24	sub sec_key
	25	{
	26	my $pkey = shift ;
	27	my $pdata = shift ;
	28
	29	$_[0] = ["a","b", "c"];
	30
	31	return 0;
	32	}
	33
	34	my ($Dfile1, $Dfile2);
	35	my $lex = new LexFile $Dfile1, $Dfile2 ;
	36	my %hash ;
	37	my $status;
	38	my ($k, $v, $pk) = ('','','');
	39
	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,
	46	-Flags => DB_CREATE ;
	47
	48	# associate primary with secondary
	49	ok $primary->associate($secondary, \&sec_key) == 0 ;
	50
	51	# add data to the primary
	52	ok $primary->db_put("foo", "bar") == 0;
	53
	54	# check the records in the secondary (there should be three "a", "b", "c")
	55	is countRecords($secondary), 3 ;
	56
	57	ok $secondary->db_get("a", $v) == 0;
	58	is $v, "bar";
	59
	60	ok $secondary->db_get("b", $v) == 0;
	61	is $v, "bar";
	62
	63	ok $secondary->db_get("c", $v) == 0;
	64	is $v, "bar";
	65	}
	66
	67	{
	68	# db->associate -- secondary keys returning DB_DBT_MULTIPLE, but with
	69	# one
	70
	71	sub sec_key1
	72	{
	73	my $pkey = shift ;
	74	my $pdata = shift ;
	75
	76	$_[0] = ["a"];
	77
	78	return 0;
	79	}
	80
	81	my ($Dfile1, $Dfile2);
	82	my $lex = new LexFile $Dfile1, $Dfile2 ;
	83	my %hash ;
	84	my $status;
	85	my ($k, $v, $pk) = ('','','');
	86
	87	# create primary database
	88	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	89	-Flags => DB_CREATE ;
	90
	91	# create secondary database
	92	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	93	-Flags => DB_CREATE ;
	94
	95	# associate primary with secondary
	96	ok $primary->associate($secondary, \&sec_key1) == 0 ;
	97
	98	# add data to the primary
	99	ok $primary->db_put("foo", "bar") == 0;
	100
	101	# check the records in the secondary (there should be three "a", "b", "c")
	102	is countRecords($secondary), 1 ;
	103
	104	ok $secondary->db_get("a", $v) == 0;
	105	is $v, "bar";
	106
	107	}
	108
	109	{
	110	# db->associate -- multiple secondary keys
	111
	112	sub sec_key_mult
	113	{
	114	#print "in sec_key\n";
	115	my $pkey = shift ;
	116	my $pdata = shift ;
	117
	118	$_[0] = [ split ',', $pdata ] ;
	119	return 0;
	120	}
	121
	122	my ($Dfile1, $Dfile2);
	123	my $lex = new LexFile $Dfile1, $Dfile2 ;
	124	my %hash ;
	125	my $status;
	126	my ($k, $v, $pk) = ('','','');
	127
	128	# create primary database
	129	ok my $primary = new BerkeleyDB::Hash -Filename => $Dfile1,
	130	-Flags => DB_CREATE ;
	131
	132	# create secondary database
	133	ok my $secondary = new BerkeleyDB::Hash -Filename => $Dfile2,
	134	-Flags => DB_CREATE ;
	135
	136	# associate primary with secondary
	137	ok $primary->associate($secondary, \&sec_key_mult) == 0;
	138
	139	# add data to the primary
	140	my %data = (
	141	"red" => "flag",
	142	"green" => "house",
	143	"blue" => "sea",
	144	"foo" => "",
	145	"bar" => "hello,goodbye",
	146	) ;
	147
	148	my $ret = 0 ;
	149	while (($k, $v) = each %data) {
	150	my $r = $primary->db_put($k, $v) ;
	151	$ret += $r;
	152	}
	153	ok $ret == 0 ;
	154
	155	# check the records in the secondary
	156	is countRecords($secondary), 5 ;
	157
	158	ok $secondary->db_get("house", $v) == 0;
	159	ok $v eq "house";
	160
	161	ok $secondary->db_get("sea", $v) == 0;
	162	ok $v eq "sea";
	163
	164	ok $secondary->db_get("flag", $v) == 0;
	165	ok $v eq "flag";
	166
	167	ok $secondary->db_get("hello", $v) == 0;
	168	ok $v eq "hello,goodbye";
	169
	170	ok $secondary->db_get("goodbye", $v) == 0;
	171	ok $v eq "hello,goodbye";
	172
	173	# pget to primary database is illegal
	174	ok $primary->db_pget('red', $pk, $v) != 0 ;
	175
	176	# pget to secondary database is ok
	177	ok $secondary->db_pget('house', $pk, $v) == 0 ;
	178	ok $pk eq 'green';
	179	ok $v eq 'house';
	180
	181	# pget to secondary database is ok
	182	ok $secondary->db_pget('hello', $pk, $v) == 0 ;
	183	ok $pk eq 'bar';
	184	ok $v eq 'hello,goodbye';
	185
	186	ok my $p_cursor = $primary->db_cursor();
	187	ok my $s_cursor = $secondary->db_cursor();
	188
	189	# c_get from primary
	190	$k = 'green';
	191	ok $p_cursor->c_get($k, $v, DB_SET) == 0;
	192	ok $k eq 'green';
	193	ok $v eq 'house';
	194
	195	# c_get from secondary
	196	$k = 'sea';
	197	ok $s_cursor->c_get($k, $v, DB_SET) == 0;
	198	ok $k eq 'sea';
	199	ok $v eq 'sea';
	200
	201	# c_pget from primary database should fail
	202	$k = 1;
	203	ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
	204
	205	# c_pget from secondary database
	206	$k = 'flag';
	207	ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
	208	ok $k eq 'flag';
	209	ok $pk eq 'red';
	210	ok $v eq 'flag';
	211
	212	# check put to secondary is illegal
	213	ok $secondary->db_put("tom", "dick") != 0;
	214	is countRecords($secondary), 5 ;
	215
	216	# delete from primary
	217	ok $primary->db_del("green") == 0 ;
	218	is countRecords($primary), 4 ;
	219
	220	# check has been deleted in secondary
	221	ok $secondary->db_get("house", $v) != 0;
	222	is countRecords($secondary), 4 ;
	223
	224	# delete from secondary
	225	ok $secondary->db_del('flag') == 0 ;
	226	is countRecords($secondary), 3 ;
	227
	228
	229	# check deleted from primary
	230	ok $primary->db_get("red", $v) != 0;
	231	is countRecords($primary), 3 ;
	232	}
	233

+42

-0

t/db-4.7.t less more

	0	#!./perl -w
	1
	2	use strict ;
	3
	4
	5	use lib 't' ;
	6
	7	use BerkeleyDB;
	8	use util ;
	9
	10	use Test::More ;
	11
	12	plan(skip_all => "this needs Berkeley DB 4.7.x or better\n" )
	13	if $BerkeleyDB::db_version < 4.7;
	14
	15	plan tests => 7;
	16
	17	my $Dfile = "dbhash.tmp";
	18
	19	umask(0);
	20
	21	{
	22	my $home = "./fred" ;
	23	ok my $lexD = new LexDir($home) ;
	24	chdir "./fred" ;
	25	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_LOG @StdErrFile;
	26
	27	ok $env->log_get_config( DB_LOG_AUTO_REMOVE, my $on ) == 0, "get config" ;
	28	ok !$on, "config value" ;
	29
	30	ok $env->log_set_config( DB_LOG_AUTO_REMOVE, 1 ) == 0;
	31
	32	ok $env->log_get_config( DB_LOG_AUTO_REMOVE, $on ) == 0;
	33	ok $on;
	34
	35	chdir ".." ;
	36	undef $env ;
	37	}
	38
	39	# test -Verbose
	40	# test -Flags
	41	# db_value_set

-1

t/db-4.x.t less more

3	3	use lib 't';
4	4	use BerkeleyDB;
5	5	use Test::More;
6		use util (1);
	6	use util ;
7	7
8	8	plan(skip_all => "this needs Berkeley DB 4.x.x or better\n" )
9	9	if $BerkeleyDB::db_version < 4;

+17

-16

t/destroy.t less more

4	4	use lib 't' ;
5	5	use BerkeleyDB;
6	6	use util ;
	7	use Test::More;
7	8
8		print "1..15\n";
	9	plan tests => 15;
9	10
10	11	my $Dfile = "dbhash.tmp";
11	12	my $home = "./fred" ;

19	20	my %hash ;
20	21	my $value ;
21	22
22		ok 1, my $lexD = new LexDir($home) ;
23		ok 2, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	23	ok my $lexD = new LexDir($home) ;
	24	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
24	25	-Flags => DB_CREATE\|DB_INIT_TXN\|
25	26	DB_INIT_MPOOL\|DB_INIT_LOCK ;
26		ok 3, my $txn = $env->txn_begin() ;
27		ok 4, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	27	ok my $txn = $env->txn_begin() ;
	28	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
28	29	-Flags => DB_CREATE ,
29	30	-Env => $env,
30	31	-Txn => $txn ;
31	32
32		ok 5, $txn->txn_commit() == 0 ;
33		ok 6, $txn = $env->txn_begin() ;
	33	ok $txn->txn_commit() == 0 ;
	34	ok $txn = $env->txn_begin() ;
34	35	$db1->Txn($txn);
35	36
36	37	# create some data

44	45	while (my ($k, $v) = each %data) {
45	46	$ret += $db1->db_put($k, $v) ;
46	47	}
47		ok 7, $ret == 0 ;
	48	ok $ret == 0 ;
48	49
49	50	# should be able to see all the records
50	51
51		ok 8, my $cursor = $db1->db_cursor() ;
	52	ok my $cursor = $db1->db_cursor() ;
52	53	my ($k, $v) = ("", "") ;
53	54	my $count = 0 ;
54	55	# sequence forwards
55	56	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
56	57	++ $count ;
57	58	}
58		ok 9, $count == 3 ;
	59	is $count, 3 ;
59	60	undef $cursor ;
60	61
61	62	# now abort the transaction
62		ok 10, $txn->txn_abort() == 0 ;
	63	ok $txn->txn_abort() == 0 ;
63	64
64	65	# there shouldn't be any records in the database
65	66	$count = 0 ;
66	67	# sequence forwards
67		ok 11, $cursor = $db1->db_cursor() ;
	68	ok $cursor = $db1->db_cursor() ;
68	69	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
69	70	++ $count ;
70	71	}
71		ok 12, $count == 0 ;
	72	is $count, 0 ;
72	73
73	74	#undef $txn ;
74	75	#undef $cursor ;

83	84	my %hash ;
84	85	my $cursor ;
85	86	my ($k, $v) = ("", "") ;
86		ok 13, my $db1 = tie %hash, 'BerkeleyDB::Hash',
	87	ok my $db1 = tie %hash, 'BerkeleyDB::Hash',
87	88	-Filename => $Dfile,
88	89	-Flags => DB_CREATE ;
89	90	my $count = 0 ;
90	91	# sequence forwards
91		ok 14, $cursor = $db1->db_cursor() ;
	92	ok $cursor = $db1->db_cursor() ;
92	93	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
93	94	++ $count ;
94	95	}
95		ok 15, $count == 0 ;
	96	is $count, 0 ;
96	97	}
97	98
98	99

+109

-113

t/encrypt.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		BEGIN
11		{
12		if ($BerkeleyDB::db_version < 4.1) {
13		print "1..0 # Skip: this needs Berkeley DB 4.1.x or better\n" ;
14		exit 0 ;
15		}
	9	use Test::More;
	10
	11	BEGIN {
	12	plan(skip_all => "this needs BerkeleyDB 4.1.x or better" )
	13	if $BerkeleyDB::db_version < 4.1;
16	14
17	15	# Is encryption available?
18	16	my $env = new BerkeleyDB::Env @StdErrFile,

20	18	Flags => DB_ENCRYPT_AES
21	19	};
22	20
23		if ($BerkeleyDB::Error =~ /Operation not supported/)
24		{
25		print "1..0 # Skip: encryption support not present\n" ;
26		exit 0 ;
27		}
28		}
	21	plan skip_all => "encryption support not present"
	22	if $BerkeleyDB::Error =~ /Operation not supported/;
	23
	24	plan tests => 80;
	25	}
	26
29	27
30	28	umask(0);
31
32		print "1..80\n";
33	29
34	30	{
35	31	eval

38	34	-Encrypt => 1,
39	35	-Flags => DB_CREATE ;
40	36	};
41		ok 1, $@ =~ /^Encrypt parameter must be a hash reference at/;
	37	ok $@ =~ /^Encrypt parameter must be a hash reference at/;
42	38
43	39	eval
44	40	{

46	42	-Encrypt => {},
47	43	-Flags => DB_CREATE ;
48	44	};
49		ok 2, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	45	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
50	46
51	47	eval
52	48	{

54	50	-Encrypt => {Password => "fred"},
55	51	-Flags => DB_CREATE ;
56	52	};
57		ok 3, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	53	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
58	54
59	55	eval
60	56	{

62	58	-Encrypt => {Flags => 1},
63	59	-Flags => DB_CREATE ;
64	60	};
65		ok 4, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	61	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
66	62
67	63	eval
68	64	{

70	66	-Encrypt => {Fred => 1},
71	67	-Flags => DB_CREATE ;
72	68	};
73		ok 5, $@ =~ /^\Qunknown key value(s) Fred at/;
	69	ok $@ =~ /^\Qunknown key value(s) Fred at/;
74	70
75	71	}
76	72

80	76	# create an environment with a Home
81	77	my $home = "./fred" ;
82	78	#mkdir $home;
83		ok 6, my $lexD = new LexDir($home) ;
84		ok 7, my $env = new BerkeleyDB::Env @StdErrFile,
	79	ok my $lexD = new LexDir($home) ;
	80	ok my $env = new BerkeleyDB::Env @StdErrFile,
85	81	-Home => $home,
86	82	-Encrypt => {Password => "abc",
87	83	Flags => DB_ENCRYPT_AES

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

110	106	while (($k, $v) = each %data) {
111	107	$ret += $db->db_put($k, $v) ;
112	108	}
113		ok 9, $ret == 0 ;
114
115		# check there are three records
116		ok 10, countRecords($db) == 3 ;
	109	ok $ret == 0 ;
	110
	111	# check there are three records
	112	ok countRecords($db) == 3 ;
117	113
118	114	undef $db;
119	115
120	116	# once the database is created, do not need to specify DB_ENCRYPT
121		ok 11, my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	117	ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
122	118	-Env => $env,
123	119	-Flags => DB_CREATE ;
124	120	$v = '';
125		ok 12, ! $db1->db_get("red", $v) ;
126		ok 13, $v eq $data{"red"},
	121	ok ! $db1->db_get("red", $v) ;
	122	ok $v eq $data{"red"},
127	123	undef $db1;
128	124	undef $env;
129	125
130	126	# open a database without specifying encryption
131		ok 14, ! new BerkeleyDB::Hash -Filename => "$home/$Dfile";
132
133		ok 15, ! new BerkeleyDB::Env
	127	ok ! new BerkeleyDB::Hash -Filename => "$home/$Dfile";
	128
	129	ok ! new BerkeleyDB::Env
134	130	-Home => $home,
135	131	-Encrypt => {Password => "def",
136	132	Flags => DB_ENCRYPT_AES

145	141	-Encrypt => 1,
146	142	-Flags => DB_CREATE ;
147	143	};
148		ok 16, $@ =~ /^Encrypt parameter must be a hash reference at/;
	144	ok $@ =~ /^Encrypt parameter must be a hash reference at/;
149	145
150	146	eval
151	147	{

153	149	-Encrypt => {},
154	150	-Flags => DB_CREATE ;
155	151	};
156		ok 17, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	152	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
157	153
158	154	eval
159	155	{

161	157	-Encrypt => {Password => "fred"},
162	158	-Flags => DB_CREATE ;
163	159	};
164		ok 18, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	160	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
165	161
166	162	eval
167	163	{

169	165	-Encrypt => {Flags => 1},
170	166	-Flags => DB_CREATE ;
171	167	};
172		ok 19, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	168	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
173	169
174	170	eval
175	171	{

177	173	-Encrypt => {Fred => 1},
178	174	-Flags => DB_CREATE ;
179	175	};
180		ok 20, $@ =~ /^\Qunknown key value(s) Fred at/;
	176	ok $@ =~ /^\Qunknown key value(s) Fred at/;
181	177
182	178	}
183	179

188	184	-Encrypt => 1,
189	185	-Flags => DB_CREATE ;
190	186	};
191		ok 21, $@ =~ /^Encrypt parameter must be a hash reference at/;
	187	ok $@ =~ /^Encrypt parameter must be a hash reference at/;
192	188
193	189	eval
194	190	{

196	192	-Encrypt => {},
197	193	-Flags => DB_CREATE ;
198	194	};
199		ok 22, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	195	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
200	196
201	197	eval
202	198	{

204	200	-Encrypt => {Password => "fred"},
205	201	-Flags => DB_CREATE ;
206	202	};
207		ok 23, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	203	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
208	204
209	205	eval
210	206	{

212	208	-Encrypt => {Flags => 1},
213	209	-Flags => DB_CREATE ;
214	210	};
215		ok 24, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	211	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
216	212
217	213	eval
218	214	{

220	216	-Encrypt => {Fred => 1},
221	217	-Flags => DB_CREATE ;
222	218	};
223		ok 25, $@ =~ /^\Qunknown key value(s) Fred at/;
	219	ok $@ =~ /^\Qunknown key value(s) Fred at/;
224	220
225	221	}
226	222

231	227	-Encrypt => 1,
232	228	-Flags => DB_CREATE ;
233	229	};
234		ok 26, $@ =~ /^Encrypt parameter must be a hash reference at/;
	230	ok $@ =~ /^Encrypt parameter must be a hash reference at/;
235	231
236	232	eval
237	233	{

239	235	-Encrypt => {},
240	236	-Flags => DB_CREATE ;
241	237	};
242		ok 27, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	238	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
243	239
244	240	eval
245	241	{

247	243	-Encrypt => {Password => "fred"},
248	244	-Flags => DB_CREATE ;
249	245	};
250		ok 28, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	246	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
251	247
252	248	eval
253	249	{

255	251	-Encrypt => {Flags => 1},
256	252	-Flags => DB_CREATE ;
257	253	};
258		ok 29, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	254	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
259	255
260	256	eval
261	257	{

263	259	-Encrypt => {Fred => 1},
264	260	-Flags => DB_CREATE ;
265	261	};
266		ok 30, $@ =~ /^\Qunknown key value(s) Fred at/;
	262	ok $@ =~ /^\Qunknown key value(s) Fred at/;
267	263
268	264	}
269	265

274	270	-Encrypt => 1,
275	271	-Flags => DB_CREATE ;
276	272	};
277		ok 31, $@ =~ /^Encrypt parameter must be a hash reference at/;
	273	ok $@ =~ /^Encrypt parameter must be a hash reference at/;
278	274
279	275	eval
280	276	{

282	278	-Encrypt => {},
283	279	-Flags => DB_CREATE ;
284	280	};
285		ok 32, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	281	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
286	282
287	283	eval
288	284	{

290	286	-Encrypt => {Password => "fred"},
291	287	-Flags => DB_CREATE ;
292	288	};
293		ok 33, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	289	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
294	290
295	291	eval
296	292	{

298	294	-Encrypt => {Flags => 1},
299	295	-Flags => DB_CREATE ;
300	296	};
301		ok 34, $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
	297	ok $@ =~ /^Must specify Password and Flags with Encrypt parameter at/;
302	298
303	299	eval
304	300	{

306	302	-Encrypt => {Fred => 1},
307	303	-Flags => DB_CREATE ;
308	304	};
309		ok 35, $@ =~ /^\Qunknown key value(s) Fred at/;
	305	ok $@ =~ /^\Qunknown key value(s) Fred at/;
310	306
311	307	}
312	308

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

337	333	while (($k, $v) = each %data) {
338	334	$ret += $db->db_put($k, $v) ;
339	335	}
340		ok 37, $ret == 0 ;
341
342		# check there are three records
343		ok 38, countRecords($db) == 3 ;
	336	ok $ret == 0 ;
	337
	338	# check there are three records
	339	ok countRecords($db) == 3 ;
344	340
345	341	undef $db;
346	342
347	343	# attempt to open a database without specifying encryption
348		ok 39, ! new BerkeleyDB::Hash -Filename => $Dfile,
	344	ok ! new BerkeleyDB::Hash -Filename => $Dfile,
349	345	-Flags => DB_CREATE ;
350	346
351	347
352	348	# try opening with the wrong password
353		ok 40, ! new BerkeleyDB::Hash -Filename => $Dfile,
	349	ok ! new BerkeleyDB::Hash -Filename => $Dfile,
354	350	-Filename => $Dfile,
355	351	-Encrypt => {Password => "def",
356	352	Flags => DB_ENCRYPT_AES

359	355
360	356
361	357	# read the encrypted data
362		ok 41, my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
	358	ok my $db1 = new BerkeleyDB::Hash -Filename => $Dfile,
363	359	-Filename => $Dfile,
364	360	-Encrypt => {Password => "beta",
365	361	Flags => DB_ENCRYPT_AES

368	364
369	365
370	366	$v = '';
371		ok 42, ! $db1->db_get("red", $v) ;
372		ok 43, $v eq $data{"red"};
373		# check there are three records
374		ok 44, countRecords($db1) == 3 ;
	367	ok ! $db1->db_get("red", $v) ;
	368	ok $v eq $data{"red"};
	369	# check there are three records
	370	ok countRecords($db1) == 3 ;
375	371	undef $db1;
376	372	}
377	373

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

401	397	while (($k, $v) = each %data) {
402	398	$ret += $db->db_put($k, $v) ;
403	399	}
404		ok 46, $ret == 0 ;
405
406		# check there are three records
407		ok 47, countRecords($db) == 3 ;
	400	ok $ret == 0 ;
	401
	402	# check there are three records
	403	ok countRecords($db) == 3 ;
408	404
409	405	undef $db;
410	406
411	407	# attempt to open a database without specifying encryption
412		ok 48, ! new BerkeleyDB::Btree -Filename => $Dfile,
	408	ok ! new BerkeleyDB::Btree -Filename => $Dfile,
413	409	-Flags => DB_CREATE ;
414	410
415	411
416	412	# try opening with the wrong password
417		ok 49, ! new BerkeleyDB::Btree -Filename => $Dfile,
	413	ok ! new BerkeleyDB::Btree -Filename => $Dfile,
418	414	-Filename => $Dfile,
419	415	-Encrypt => {Password => "def",
420	416	Flags => DB_ENCRYPT_AES

423	419
424	420
425	421	# read the encrypted data
426		ok 50, my $db1 = new BerkeleyDB::Btree -Filename => $Dfile,
	422	ok my $db1 = new BerkeleyDB::Btree -Filename => $Dfile,
427	423	-Filename => $Dfile,
428	424	-Encrypt => {Password => "beta",
429	425	Flags => DB_ENCRYPT_AES

432	428
433	429
434	430	$v = '';
435		ok 51, ! $db1->db_get("red", $v) ;
436		ok 52, $v eq $data{"red"};
437		# check there are three records
438		ok 53, countRecords($db1) == 3 ;
	431	ok ! $db1->db_get("red", $v) ;
	432	ok $v eq $data{"red"};
	433	# check there are three records
	434	ok countRecords($db1) == 3 ;
439	435	undef $db1;
440	436	}
441	437

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

467	463	while (($k, $v) = each %data) {
468	464	$ret += $db->db_put($k, $v) ;
469	465	}
470		ok 55, $ret == 0 ;
471
472		# check there are three records
473		ok 56, countRecords($db) == 3 ;
	466	ok $ret == 0 ;
	467
	468	# check there are three records
	469	ok countRecords($db) == 3 ;
474	470
475	471	undef $db;
476	472
477	473	# attempt to open a database without specifying encryption
478		ok 57, ! new BerkeleyDB::Queue -Filename => $Dfile,
	474	ok ! new BerkeleyDB::Queue -Filename => $Dfile,
479	475	-Len => 5,
480	476	-Pad => "x",
481	477	-Flags => DB_CREATE ;
482	478
483	479
484	480	# try opening with the wrong password
485		ok 58, ! new BerkeleyDB::Queue -Filename => $Dfile,
	481	ok ! new BerkeleyDB::Queue -Filename => $Dfile,
486	482	-Len => 5,
487	483	-Pad => "x",
488	484	-Encrypt => {Password => "def",

492	488
493	489
494	490	# read the encrypted data
495		ok 59, my $db1 = new BerkeleyDB::Queue -Filename => $Dfile,
	491	ok my $db1 = new BerkeleyDB::Queue -Filename => $Dfile,
496	492	-Len => 5,
497	493	-Pad => "x",
498	494	-Encrypt => {Password => "beta",

502	498
503	499
504	500	$v = '';
505		ok 60, ! $db1->db_get(3, $v) ;
506		ok 61, $v eq fillout($data{3}, 5, 'x');
507		# check there are three records
508		ok 62, countRecords($db1) == 3 ;
	501	ok ! $db1->db_get(3, $v) ;
	502	ok $v eq fillout($data{3}, 5, 'x');
	503	# check there are three records
	504	ok countRecords($db1) == 3 ;
509	505	undef $db1;
510	506	}
511	507

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

535	531	while (($k, $v) = each %data) {
536	532	$ret += $db->db_put($k, $v) ;
537	533	}
538		ok 64, $ret == 0 ;
539
540		# check there are three records
541		ok 65, countRecords($db) == 3 ;
	534	ok $ret == 0 ;
	535
	536	# check there are three records
	537	ok countRecords($db) == 3 ;
542	538
543	539	undef $db;
544	540
545	541	# attempt to open a database without specifying encryption
546		ok 66, ! new BerkeleyDB::Recno -Filename => $Dfile,
	542	ok ! new BerkeleyDB::Recno -Filename => $Dfile,
547	543	-Flags => DB_CREATE ;
548	544
549	545
550	546	# try opening with the wrong password
551		ok 67, ! new BerkeleyDB::Recno -Filename => $Dfile,
	547	ok ! new BerkeleyDB::Recno -Filename => $Dfile,
552	548	-Filename => $Dfile,
553	549	-Encrypt => {Password => "def",
554	550	Flags => DB_ENCRYPT_AES

557	553
558	554
559	555	# read the encrypted data
560		ok 68, my $db1 = new BerkeleyDB::Recno -Filename => $Dfile,
	556	ok my $db1 = new BerkeleyDB::Recno -Filename => $Dfile,
561	557	-Filename => $Dfile,
562	558	-Encrypt => {Password => "beta",
563	559	Flags => DB_ENCRYPT_AES

566	562
567	563
568	564	$v = '';
569		ok 69, ! $db1->db_get(3, $v) ;
570		ok 70, $v eq $data{3};
571		# check there are three records
572		ok 71, countRecords($db1) == 3 ;
	565	ok ! $db1->db_get(3, $v) ;
	566	ok $v eq $data{3};
	567	# check there are three records
	568	ok countRecords($db1) == 3 ;
573	569	undef $db1;
574	570	}
575	571

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

599	595	while (($k, $v) = each %data) {
600	596	$ret += $db->db_put($k, $v) ;
601	597	}
602		ok 73, $ret == 0 ;
603
604		# check there are three records
605		ok 74, countRecords($db) == 3 ;
	598	ok $ret == 0 ;
	599
	600	# check there are three records
	601	ok countRecords($db) == 3 ;
606	602
607	603	undef $db;
608	604
609	605	# attempt to open a database without specifying encryption
610		ok 75, ! new BerkeleyDB::Unknown -Filename => $Dfile,
	606	ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
611	607	-Flags => DB_CREATE ;
612	608
613	609
614	610	# try opening with the wrong password
615		ok 76, ! new BerkeleyDB::Unknown -Filename => $Dfile,
	611	ok ! new BerkeleyDB::Unknown -Filename => $Dfile,
616	612	-Filename => $Dfile,
617	613	-Encrypt => {Password => "def",
618	614	Flags => DB_ENCRYPT_AES

621	617
622	618
623	619	# read the encrypted data
624		ok 77, my $db1 = new BerkeleyDB::Unknown -Filename => $Dfile,
	620	ok my $db1 = new BerkeleyDB::Unknown -Filename => $Dfile,
625	621	-Filename => $Dfile,
626	622	-Encrypt => {Password => "beta",
627	623	Flags => DB_ENCRYPT_AES

630	626
631	627
632	628	$v = '';
633		ok 78, ! $db1->db_get("red", $v) ;
634		ok 79, $v eq $data{"red"};
635		# check there are three records
636		ok 80, countRecords($db1) == 3 ;
	629	ok ! $db1->db_get("red", $v) ;
	630	ok $v eq $data{"red"};
	631	# check there are three records
	632	ok countRecords($db1) == 3 ;
637	633	undef $db1;
638	634	}
639	635

+62

-60

t/env.t less more

11	11	use BerkeleyDB;
12	12	use util ;
13	13
14		print "1..53\n";
	14	use Test::More ;
	15
	16	plan tests => 53;
15	17
16	18	my $Dfile = "dbhash.tmp";
17	19

23	25	# db version stuff
24	26	my ($major, $minor, $patch) = (0, 0, 0) ;
25	27
26		ok 1, my $VER = BerkeleyDB::DB_VERSION_STRING ;
27		ok 2, my $ver = BerkeleyDB::db_version($version_major, $minor, $patch) ;
28		ok 3, $VER eq $ver ;
29		ok 4, $version_major > 1 ;
30		ok 5, defined $minor ;
31		ok 6, defined $patch ;
	28	ok my $VER = BerkeleyDB::DB_VERSION_STRING ;
	29	ok my $ver = BerkeleyDB::db_version($version_major, $minor, $patch) ;
	30	ok $VER eq $ver ;
	31	ok $version_major > 1 ;
	32	ok defined $minor ;
	33	ok defined $patch ;
32	34	}
33	35
34	36	{
35	37	# Check for invalid parameters
36	38	my $env ;
37	39	eval ' $env = new BerkeleyDB::Env( -Stupid => 3) ; ' ;
38		ok 7, $@ =~ /unknown key value$s$ Stupid/ ;
	40	ok $@ =~ /unknown key value$s$ Stupid/ ;
39	41
40	42	eval ' $env = new BerkeleyDB::Env( -Bad => 2, -Home => "/tmp", -Stupid => 3) ; ' ;
41		ok 8, $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
	43	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
42	44
43	45	eval ' $env = new BerkeleyDB::Env (-Config => {"fred" => " "} ) ; ' ;
44		ok 9, !$env ;
45		ok 10, $BerkeleyDB::Error =~ /^(illegal name-value pair\|Invalid argument)/ ;
	46	ok !$env ;
	47	ok $BerkeleyDB::Error =~ /^(illegal name-value pair\|Invalid argument)/ ;
46	48	#print " $BerkeleyDB::Error\n";
47	49	}
48	50
49	51	{
50	52	# create a very simple environment
51	53	my $home = "./fred" ;
52		ok 11, my $lexD = new LexDir($home) ;
	54	ok my $lexD = new LexDir($home) ;
53	55	chdir "./fred" ;
54		ok 12, my $env = new BerkeleyDB::Env -Flags => DB_CREATE,
	56	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE,
55	57	@StdErrFile;
56	58	chdir ".." ;
57	59	undef $env ;

60	62	{
61	63	# create an environment with a Home
62	64	my $home = "./fred" ;
63		ok 13, my $lexD = new LexDir($home) ;
64		ok 14, my $env = new BerkeleyDB::Env -Home => $home,
	65	ok my $lexD = new LexDir($home) ;
	66	ok my $env = new BerkeleyDB::Env -Home => $home,
65	67	-Flags => DB_CREATE ;
66	68
67	69	undef $env ;

71	73	# make new fail.
72	74	my $home = "./not_there" ;
73	75	rmtree $home ;
74		ok 15, ! -d $home ;
	76	ok ! -d $home ;
75	77	my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
76	78	-Flags => DB_INIT_LOCK ;
77		ok 16, ! $env ;
78		ok 17, $! != 0 \|\| $^E != 0 ;
	79	ok ! $env ;
	80	ok $! != 0 \|\| $^E != 0 ;
79	81
80	82	rmtree $home ;
81	83	}

88	90	my $data_dir = "$home/data_dir" ;
89	91	my $log_dir = "$home/log_dir" ;
90	92	my $data_file = "data.db" ;
91		ok 18, my $lexD = new LexDir($home) ;
92		ok 19, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
93		ok 20, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
	93	ok my $lexD = new LexDir($home) ;
	94	ok -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
	95	ok -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
94	96	my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
95	97	-Config => { DB_DATA_DIR => $data_dir,
96	98	DB_LOG_DIR => $log_dir
97	99	},
98	100	-Flags => DB_CREATE\|DB_INIT_TXN\|DB_INIT_LOG\|
99	101	DB_INIT_MPOOL\|DB_INIT_LOCK ;
100		ok 21, $env ;
101
102		ok 22, my $txn = $env->txn_begin() ;
	102	ok $env ;
	103
	104	ok my $txn = $env->txn_begin() ;
103	105
104	106	my %hash ;
105		ok 23, tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file,
	107	ok tie %hash, 'BerkeleyDB::Hash', -Filename => $data_file,
106	108	-Flags => DB_CREATE ,
107	109	-Env => $env,
108	110	-Txn => $txn ;

137	139	# -ErrFile with a filename
138	140	my $errfile = "./errfile" ;
139	141	my $home = "./fred" ;
140		ok 24, my $lexD = new LexDir($home) ;
	142	ok my $lexD = new LexDir($home) ;
141	143	my $lex = new LexFile $errfile ;
142		ok 25, my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
	144	ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
143	145	-Flags => DB_CREATE,
144	146	-Home => $home) ;
145	147	my $db = new BerkeleyDB::Hash -Filename => $Dfile,
146	148	-Env => $env,
147	149	-Flags => -1;
148		ok 26, !$db ;
	150	ok !$db ;
149	151
150	152	my $ErrMsg = join "'", 'illegal flag specified to (db_open\|DB->open)',
151	153	'DB_AUTO_COMMIT may not be specified in non-transactional environment';
152	154
153		ok 27, chkMsg();
154		ok 28, -e $errfile ;
	155	ok chkMsg();
	156	ok -e $errfile ;
155	157	my $contents = docat($errfile) ;
156	158	chomp $contents ;
157		ok 29, $BerkeleyDB::Error eq $contents ;
	159	ok $BerkeleyDB::Error eq $contents ;
158	160
159	161	undef $env ;
160	162	}

164	166	use IO::File ;
165	167	my $errfile = "./errfile" ;
166	168	my $home = "./fred" ;
167		ok 30, my $lexD = new LexDir($home) ;
	169	ok my $lexD = new LexDir($home) ;
168	170	my $lex = new LexFile $errfile ;
169	171	my $fh = new IO::File ">$errfile" ;
170		ok 31, my $env = new BerkeleyDB::Env( -ErrFile => $fh,
	172	ok my $env = new BerkeleyDB::Env( -ErrFile => $fh,
171	173	-Flags => DB_CREATE,
172	174	-Home => $home) ;
173	175	my $db = new BerkeleyDB::Hash -Filename => $Dfile,
174	176	-Env => $env,
175	177	-Flags => -1;
176		ok 32, !$db ;
177
178		ok 33, chkMsg();
179		ok 34, -e $errfile ;
	178	ok !$db ;
	179
	180	ok chkMsg();
	181	ok -e $errfile ;
180	182	my $contents = docat($errfile) ;
181	183	chomp $contents ;
182		ok 35, $BerkeleyDB::Error eq $contents ;
	184	ok $BerkeleyDB::Error eq $contents ;
183	185
184	186	undef $env ;
185	187	}

187	189	{
188	190	# -ErrPrefix
189	191	my $home = "./fred" ;
190		ok 36, my $lexD = new LexDir($home) ;
	192	ok my $lexD = new LexDir($home) ;
191	193	my $errfile = "./errfile" ;
192	194	my $lex = new LexFile $errfile ;
193		ok 37, my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
	195	ok my $env = new BerkeleyDB::Env( -ErrFile => $errfile,
194	196	-ErrPrefix => "PREFIX",
195	197	-Flags => DB_CREATE,
196	198	-Home => $home) ;
197	199	my $db = new BerkeleyDB::Hash -Filename => $Dfile,
198	200	-Env => $env,
199	201	-Flags => -1;
200		ok 38, !$db ;
201
202		ok 39, chkMsg('PREFIX');
203		ok 40, -e $errfile ;
	202	ok !$db ;
	203
	204	ok chkMsg('PREFIX');
	205	ok -e $errfile ;
204	206	my $contents = docat($errfile) ;
205	207	chomp $contents ;
206		ok 41, $BerkeleyDB::Error eq $contents ;
	208	ok $BerkeleyDB::Error eq $contents ;
207	209
208	210	# change the prefix on the fly
209	211	my $old = $env->errPrefix("NEW ONE") ;
210		ok 42, $old eq "PREFIX" ;
	212	ok $old eq "PREFIX" ;
211	213
212	214	$db = new BerkeleyDB::Hash -Filename => $Dfile,
213	215	-Env => $env,
214	216	-Flags => -1;
215		ok 43, !$db ;
216		ok 44, chkMsg('NEW ONE');
	217	ok !$db ;
	218	ok chkMsg('NEW ONE');
217	219	$contents = docat($errfile) ;
218	220	chomp $contents ;
219		ok 45, $contents =~ /$BerkeleyDB::Error$/ ;
	221	ok $contents =~ /$BerkeleyDB::Error$/ ;
220	222	undef $env ;
221	223	}
222	224

228	230	my $data_dir = "$home/data_dir" ;
229	231	my $log_dir = "$home/log_dir" ;
230	232	my $data_file = "data.db" ;
231		ok 46, my $lexD = new LexDir($home);
232		ok 47, -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
233		ok 48, -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
	233	ok my $lexD = new LexDir($home);
	234	ok -d $data_dir ? chmod 0777, $data_dir : mkdir($data_dir, 0777) ;
	235	ok -d $log_dir ? chmod 0777, $log_dir : mkdir($log_dir, 0777) ;
234	236	my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
235	237	-Config => { DB_DATA_DIR => $data_dir,
236	238	DB_LOG_DIR => $log_dir
237	239	},
238	240	-Flags => DB_CREATE\|DB_INIT_TXN\|DB_INIT_LOG\|
239	241	DB_INIT_MPOOL\|DB_INIT_LOCK ;
240		ok 49, $env ;
241
242		ok 50, my $txn_mgr = $env->TxnMgr() ;
243
244		ok 51, $env->db_appexit() == 0 ;
	242	ok $env ;
	243
	244	ok my $txn_mgr = $env->TxnMgr() ;
	245
	246	ok $env->db_appexit() == 0 ;
245	247
246	248	}
247	249

250	252	# should fail with Berkeley DB 3.x or better.
251	253
252	254	my $home = "./fred" ;
253		ok 52, my $lexD = new LexDir($home) ;
	255	ok my $lexD = new LexDir($home) ;
254	256	chdir "./fred" ;
255	257	my $env = new BerkeleyDB::Env -Home => $home, -Flags => DB_CREATE ;
256		ok 53, $version_major == 2 ? $env : ! $env ;
	258	ok $version_major == 2 ? $env : ! $env ;
257	259
258	260	# The test below is not portable -- the error message returned by
259	261	# $BerkeleyDB::Error is locale dependant.
260	262
261		#ok 54, $version_major == 2 ? 1
	263	#ok $version_major == 2 ? 1
262	264	# : $BerkeleyDB::Error =~ /No such file or directory/ ;
263	265	# or print "# BerkeleyDB::Error is $BerkeleyDB::Error\n";
264	266	chdir ".." ;

-1

t/examples.t less more

11	11	use lib 't';
12	12	use BerkeleyDB;
13	13	use Test::More;
14		use util(1);
	14	use util;
15	15
16	16	plan tests => 7;
17	17

-1

t/examples.t.T less more

11	11	use lib 't';
12	12	use BerkeleyDB;
13	13	use Test::More;
14		use util(1);
	14	use util;
15	15
16	16	plan tests => 7;
17	17

-1

t/examples3.t less more

11	11	use lib 't';
12	12	use BerkeleyDB;
13	13	use Test::More;
14		use util (1);
	14	use util ;
15	15
16	16	#BEGIN
17	17	#{

-1

t/examples3.t.T less more

11	11	use lib 't';
12	12	use BerkeleyDB;
13	13	use Test::More;
14		use util (1);
	14	use util ;
15	15
16	16	#BEGIN
17	17	#{

+87

-86

t/filter.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		print "1..52\n";
	9	use Test::More;
	10
	11	plan tests => 52;
11	12
12	13	my $Dfile = "dbhash.tmp";
13	14	unlink $Dfile;

31	32	$_ eq 'original' ;
32	33	}
33	34
34		ok 1, $db = tie %h, 'BerkeleyDB::Hash',
	35	ok $db = tie %h, 'BerkeleyDB::Hash',
35	36	-Filename => $Dfile,
36	37	-Flags => DB_CREATE;
37	38

44	45
45	46	$h{"fred"} = "joe" ;
46	47	# fk sk fv sv
47		ok 2, checkOutput( "", "fred", "", "joe") ;
48
49		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
50		ok 3, $h{"fred"} eq "joe";
	48	ok checkOutput( "", "fred", "", "joe") ;
	49
	50	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	51	ok $h{"fred"} eq "joe";
51	52	# fk sk fv sv
52		ok 4, checkOutput( "", "fred", "joe", "") ;
53
54		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
55		ok 5, $db->FIRSTKEY() eq "fred" ;
	53	ok checkOutput( "", "fred", "joe", "") ;
	54
	55	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	56	ok $db->FIRSTKEY() eq "fred" ;
56	57	# fk sk fv sv
57		ok 6, checkOutput( "fred", "", "", "") ;
	58	ok checkOutput( "fred", "", "", "") ;
58	59
59	60	# replace the filters, but remember the previous set
60	61	my ($old_fk) = $db->filter_fetch_key

69	70	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
70	71	$h{"Fred"} = "Joe" ;
71	72	# fk sk fv sv
72		ok 7, checkOutput( "", "fred", "", "Jxe") ;
73
74		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
75		ok 8, $h{"Fred"} eq "[Jxe]";
	73	ok checkOutput( "", "fred", "", "Jxe") ;
	74
	75	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	76	ok $h{"Fred"} eq "[Jxe]";
76	77	print "$h{'Fred'}\n";
77	78	# fk sk fv sv
78		ok 9, checkOutput( "", "fred", "[Jxe]", "") ;
79
80		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
81		ok 10, $db->FIRSTKEY() eq "FRED" ;
	79	ok checkOutput( "", "fred", "[Jxe]", "") ;
	80
	81	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	82	ok $db->FIRSTKEY() eq "FRED" ;
82	83	# fk sk fv sv
83		ok 11, checkOutput( "FRED", "", "", "") ;
	84	ok checkOutput( "FRED", "", "", "") ;
84	85
85	86	# put the original filters back
86	87	$db->filter_fetch_key ($old_fk);

90	91
91	92	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
92	93	$h{"fred"} = "joe" ;
93		ok 12, checkOutput( "", "fred", "", "joe") ;
94
95		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
96		ok 13, $h{"fred"} eq "joe";
97		ok 14, checkOutput( "", "fred", "joe", "") ;
98
99		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
100		ok 15, $db->FIRSTKEY() eq "fred" ;
101		ok 16, checkOutput( "fred", "", "", "") ;
	94	ok checkOutput( "", "fred", "", "joe") ;
	95
	96	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	97	ok $h{"fred"} eq "joe";
	98	ok checkOutput( "", "fred", "joe", "") ;
	99
	100	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	101	ok $db->FIRSTKEY() eq "fred" ;
	102	ok checkOutput( "fred", "", "", "") ;
102	103
103	104	# delete the filters
104	105	$db->filter_fetch_key (undef);

108	109
109	110	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
110	111	$h{"fred"} = "joe" ;
111		ok 17, checkOutput( "", "", "", "") ;
112
113		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
114		ok 18, $h{"fred"} eq "joe";
115		ok 19, checkOutput( "", "", "", "") ;
116
117		($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
118		ok 20, $db->FIRSTKEY() eq "fred" ;
119		ok 21, checkOutput( "", "", "", "") ;
	112	ok checkOutput( "", "", "", "") ;
	113
	114	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	115	ok $h{"fred"} eq "joe";
	116	ok checkOutput( "", "", "", "") ;
	117
	118	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	119	ok $db->FIRSTKEY() eq "fred" ;
	120	ok checkOutput( "", "", "", "") ;
120	121
121	122	undef $db ;
122	123	untie %h;

130	131	my (%h, $db) ;
131	132
132	133	unlink $Dfile;
133		ok 22, $db = tie %h, 'BerkeleyDB::Hash',
	134	ok $db = tie %h, 'BerkeleyDB::Hash',
134	135	-Filename => $Dfile,
135	136	-Flags => DB_CREATE;
136	137

156	157	$_ = "original" ;
157	158
158	159	$h{"fred"} = "joe" ;
159		ok 23, $result{"store key"} eq "store key - 1: [fred]" ;
160		ok 24, $result{"store value"} eq "store value - 1: [joe]" ;
161		ok 25, ! defined $result{"fetch key"} ;
162		ok 26, ! defined $result{"fetch value"} ;
163		ok 27, $_ eq "original" ;
164
165		ok 28, $db->FIRSTKEY() eq "fred" ;
166		ok 29, $result{"store key"} eq "store key - 1: [fred]" ;
167		ok 30, $result{"store value"} eq "store value - 1: [joe]" ;
168		ok 31, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
169		ok 32, ! defined $result{"fetch value"} ;
170		ok 33, $_ eq "original" ;
	160	ok $result{"store key"} eq "store key - 1: [fred]" ;
	161	ok $result{"store value"} eq "store value - 1: [joe]" ;
	162	ok ! defined $result{"fetch key"} ;
	163	ok ! defined $result{"fetch value"} ;
	164	ok $_ eq "original" ;
	165
	166	ok $db->FIRSTKEY() eq "fred" ;
	167	ok $result{"store key"} eq "store key - 1: [fred]" ;
	168	ok $result{"store value"} eq "store value - 1: [joe]" ;
	169	ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
	170	ok ! defined $result{"fetch value"} ;
	171	ok $_ eq "original" ;
171	172
172	173	$h{"jim"} = "john" ;
173		ok 34, $result{"store key"} eq "store key - 2: [fred jim]" ;
174		ok 35, $result{"store value"} eq "store value - 2: [joe john]" ;
175		ok 36, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
176		ok 37, ! defined $result{"fetch value"} ;
177		ok 38, $_ eq "original" ;
178
179		ok 39, $h{"fred"} eq "joe" ;
180		ok 40, $result{"store key"} eq "store key - 3: [fred jim fred]" ;
181		ok 41, $result{"store value"} eq "store value - 2: [joe john]" ;
182		ok 42, $result{"fetch key"} eq "fetch key - 1: [fred]" ;
183		ok 43, $result{"fetch value"} eq "fetch value - 1: [joe]" ;
184		ok 44, $_ eq "original" ;
	174	ok $result{"store key"} eq "store key - 2: [fred jim]" ;
	175	ok $result{"store value"} eq "store value - 2: [joe john]" ;
	176	ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
	177	ok ! defined $result{"fetch value"} ;
	178	ok $_ eq "original" ;
	179
	180	ok $h{"fred"} eq "joe" ;
	181	ok $result{"store key"} eq "store key - 3: [fred jim fred]" ;
	182	ok $result{"store value"} eq "store value - 2: [joe john]" ;
	183	ok $result{"fetch key"} eq "fetch key - 1: [fred]" ;
	184	ok $result{"fetch value"} eq "fetch value - 1: [joe]" ;
	185	ok $_ eq "original" ;
185	186
186	187	undef $db ;
187	188	untie %h;

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

216	217	my (%h, $db) ;
217	218	unlink $Dfile;
218	219
219		ok 47, $db = tie %h, 'BerkeleyDB::Hash',
	220	ok $db = tie %h, 'BerkeleyDB::Hash',
220	221	-Filename => $Dfile,
221	222	-Flags => DB_CREATE;
222	223

228	229	$_ = "original" ;
229	230
230	231	$h{"fred"} = "joe" ;
231		ok(48, $h{"fred"} eq "joe");
	232	ok($h{"fred"} eq "joe");
232	233
233	234	eval { grep { $h{$_} } (1, 2, 3) };
234		ok (49, ! $@);
	235	ok (! $@);
235	236
236	237
237	238	# delete the filters

242	243
243	244	$h{"fred"} = "joe" ;
244	245
245		ok(50, $h{"fred"} eq "joe");
246
247		ok(51, $db->FIRSTKEY() eq "fred") ;
	246	ok($h{"fred"} eq "joe");
	247
	248	ok($db->FIRSTKEY() eq "fred") ;
248	249
249	250	eval { grep { $h{$_} } (1, 2, 3) };
250		ok (52, ! $@);
	251	ok (! $@);
251	252
252	253	undef $db ;
253	254	untie %h;

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

285	286	#$db->filter_store_value (sub { -- $_ }) ;
286	287
287	288	my ($k, $v) = (0,0);
288		ok 54, ! $db->db_put(3,5);
	289	ok ! $db->db_put(3,5);
289	290	exit;
290		ok 55, ! $db->db_get(3, $v);
291		ok 56, $v == 5 ;
	291	ok ! $db->db_get(3, $v);
	292	ok $v == 5 ;
292	293
293	294	$h{4} = 7 ;
294		ok 57, $h{4} == 7;
	295	ok $h{4} == 7;
295	296
296	297	$k = 10;
297	298	$v = 30;
298	299	$h{$k} = $v ;
299		ok 58, $k == 10;
300		ok 59, $v == 30;
301		ok 60, $h{$k} == 30;
	300	ok $k == 10;
	301	ok $v == 30;
	302	ok $h{$k} == 30;
302	303
303	304	$k = 3;
304		ok 61, ! $db->db_get($k, $v, DB_GET_BOTH);
305		ok 62, $k == 3 ;
306		ok 63, $v == 5 ;
	305	ok ! $db->db_get($k, $v, DB_GET_BOTH);
	306	ok $k == 3 ;
	307	ok $v == 5 ;
307	308
308	309	my $cursor = $db->db_cursor();
309	310

313	314	$tmp{$k} = $v;
314	315	}
315	316
316		ok 64, keys %tmp == 3 ;
317		ok 65, $tmp{3} == 5;
	317	ok keys %tmp == 3 ;
	318	ok $tmp{3} == 5;
318	319
319	320	undef $cursor ;
320	321	undef $db ;

+219

-217

t/hash.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		print "1..212\n";
	9	use Test::More;
	10
	11	plan tests => 212;
11	12
12	13	my $Dfile = "dbhash.tmp";
13	14	my $Dfile2 = "dbhash2.tmp";

22	23	# Check for invalid parameters
23	24	my $db ;
24	25	eval ' $db = new BerkeleyDB::Hash -Stupid => 3 ; ' ;
25		ok 1, $@ =~ /unknown key value$s$ Stupid/ ;
	26	ok $@ =~ /unknown key value$s$ Stupid/ ;
26	27
27	28	eval ' $db = new BerkeleyDB::Hash -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
28		ok 2, $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
	29	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
29	30
30	31	eval ' $db = new BerkeleyDB::Hash -Env => 2 ' ;
31		ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	32	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
32	33
33	34	eval ' $db = new BerkeleyDB::Hash -Txn => "fred" ' ;
34		ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
	35	ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
35	36
36	37	my $obj = bless [], "main" ;
37	38	eval ' $db = new BerkeleyDB::Hash -Env => $obj ' ;
38		ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	39	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
39	40	}
40	41
41	42	# Now check the interface to HASH

43	44	{
44	45	my $lex = new LexFile $Dfile ;
45	46
46		ok 6, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	47	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
47	48	-Flags => DB_CREATE ;
48	49
49	50	# Add a k/v pair
50	51	my $value ;
51	52	my $status ;
52		ok 7, $db->db_put("some key", "some value") == 0 ;
53		ok 8, $db->status() == 0 ;
54		ok 9, $db->db_get("some key", $value) == 0 ;
55		ok 10, $value eq "some value" ;
56		ok 11, $db->db_put("key", "value") == 0 ;
57		ok 12, $db->db_get("key", $value) == 0 ;
58		ok 13, $value eq "value" ;
59		ok 14, $db->db_del("some key") == 0 ;
60		ok 15, ($status = $db->db_get("some key", $value)) == DB_NOTFOUND ;
61		ok 16, $status eq $DB_errors{'DB_NOTFOUND'} ;
62		ok 17, $db->status() == DB_NOTFOUND ;
63		ok 18, $db->status() eq $DB_errors{'DB_NOTFOUND'};
64
65		ok 19, $db->db_sync() == 0 ;
	53	ok $db->db_put("some key", "some value") == 0 ;
	54	ok $db->status() == 0 ;
	55	ok $db->db_get("some key", $value) == 0 ;
	56	ok $value eq "some value" ;
	57	ok $db->db_put("key", "value") == 0 ;
	58	ok $db->db_get("key", $value) == 0 ;
	59	ok $value eq "value" ;
	60	ok $db->db_del("some key") == 0 ;
	61	ok (($status = $db->db_get("some key", $value)) == DB_NOTFOUND) ;
	62	ok $status eq $DB_errors{'DB_NOTFOUND'} ;
	63	ok $db->status() == DB_NOTFOUND ;
	64	ok $db->status() eq $DB_errors{'DB_NOTFOUND'};
	65
	66	ok $db->db_sync() == 0 ;
66	67
67	68	# Check NOOVERWRITE will make put fail when attempting to overwrite
68	69	# an existing record.
69	70
70		ok 20, $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
71		ok 21, $db->status() eq $DB_errors{'DB_KEYEXIST'};
72		ok 22, $db->status() == DB_KEYEXIST ;
	71	ok $db->db_put( 'key', 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
	72	ok $db->status() eq $DB_errors{'DB_KEYEXIST'};
	73	ok $db->status() == DB_KEYEXIST ;
73	74
74	75	# check that the value of the key has not been changed by the
75	76	# previous test
76		ok 23, $db->db_get("key", $value) == 0 ;
77		ok 24, $value eq "value" ;
	77	ok $db->db_get("key", $value) == 0 ;
	78	ok $value eq "value" ;
78	79
79	80	# test DB_GET_BOTH
80	81	my ($k, $v) = ("key", "value") ;
81		ok 25, $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
	82	ok $db->db_get($k, $v, DB_GET_BOTH) == 0 ;
82	83
83	84	($k, $v) = ("key", "fred") ;
84		ok 26, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	85	ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
85	86
86	87	($k, $v) = ("another", "value") ;
87		ok 27, $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	88	ok $db->db_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
88	89
89	90
90	91	}

94	95	my $lex = new LexFile $Dfile ;
95	96
96	97	my $home = "./fred" ;
97		ok 28, my $lexD = new LexDir($home);
98
99		ok 29, my $env = new BerkeleyDB::Env -Flags => DB_CREATE\| DB_INIT_MPOOL,@StdErrFile,
	98	ok my $lexD = new LexDir($home);
	99
	100	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\| DB_INIT_MPOOL,@StdErrFile,
100	101	-Home => $home ;
101		ok 30, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	102	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
102	103	-Env => $env,
103	104	-Flags => DB_CREATE ;
104	105
105	106	# Add a k/v pair
106	107	my $value ;
107		ok 31, $db->db_put("some key", "some value") == 0 ;
108		ok 32, $db->db_get("some key", $value) == 0 ;
109		ok 33, $value eq "some value" ;
	108	ok $db->db_put("some key", "some value") == 0 ;
	109	ok $db->db_get("some key", $value) == 0 ;
	110	ok $value eq "some value" ;
110	111	undef $db ;
111	112	undef $env ;
112	113	}

117	118	my $lex = new LexFile $Dfile ;
118	119	my $value ;
119	120	$::count = 0 ;
120		ok 34, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	121	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
121	122	-Hash => sub { ++$::count ; length $_[0] },
122	123	-Flags => DB_CREATE ;
123	124
124		ok 35, $db->db_put("some key", "some value") == 0 ;
125		ok 36, $db->db_get("some key", $value) == 0 ;
126		ok 37, $value eq "some value" ;
127		ok 38, $::count > 0 ;
	125	ok $db->db_put("some key", "some value") == 0 ;
	126	ok $db->db_get("some key", $value) == 0 ;
	127	ok $value eq "some value" ;
	128	ok $::count > 0 ;
128	129
129	130	}
130	131

134	135	my $lex = new LexFile $Dfile ;
135	136	my %hash ;
136	137	my ($k, $v) ;
137		ok 39, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	138	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
138	139	-Flags => DB_CREATE ;
139	140
140	141	# create some data

148	149	while (($k, $v) = each %data) {
149	150	$ret += $db->db_put($k, $v) ;
150	151	}
151		ok 40, $ret == 0 ;
	152	ok $ret == 0 ;
152	153
153	154	# create the cursor
154		ok 41, my $cursor = $db->db_cursor() ;
	155	ok my $cursor = $db->db_cursor() ;
155	156
156	157	$k = $v = "" ;
157	158	my %copy = %data ;

163	164	else
164	165	{ ++ $extras }
165	166	}
166		ok 42, $cursor->status() == DB_NOTFOUND ;
167		ok 43, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
168		ok 44, keys %copy == 0 ;
169		ok 45, $extras == 0 ;
	167	ok $cursor->status() == DB_NOTFOUND ;
	168	ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
	169	ok keys %copy == 0 ;
	170	ok $extras == 0 ;
170	171
171	172	# sequence backwards
172	173	%copy = %data ;

180	181	else
181	182	{ ++ $extras }
182	183	}
183		ok 46, $status == DB_NOTFOUND ;
184		ok 47, $status eq $DB_errors{'DB_NOTFOUND'} ;
185		ok 48, $cursor->status() == $status ;
186		ok 49, $cursor->status() eq $status ;
187		ok 50, keys %copy == 0 ;
188		ok 51, $extras == 0 ;
	184	ok $status == DB_NOTFOUND ;
	185	ok $status eq $DB_errors{'DB_NOTFOUND'} ;
	186	ok $cursor->status() == $status ;
	187	ok $cursor->status() eq $status ;
	188	ok keys %copy == 0 ;
	189	ok $extras == 0 ;
189	190
190	191	($k, $v) = ("green", "house") ;
191		ok 52, $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
	192	ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
192	193
193	194	($k, $v) = ("green", "door") ;
194		ok 53, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	195	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
195	196
196	197	($k, $v) = ("black", "house") ;
197		ok 54, $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
	198	ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
198	199
199	200	}
200	201

203	204
204	205	my $lex = new LexFile $Dfile ;
205	206	my %hash ;
206		ok 55, tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	207	ok tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
207	208	-Flags => DB_CREATE ;
208	209
209	210	# check "each" with an empty database

211	212	while (my ($k, $v) = each %hash) {
212	213	++ $count ;
213	214	}
214		ok 56, (tied %hash)->status() == DB_NOTFOUND ;
215		ok 57, $count == 0 ;
	215	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	216	ok $count == 0 ;
216	217
217	218	# Add a k/v pair
218	219	my $value ;
219	220	$hash{"some key"} = "some value";
220		ok 58, (tied %hash)->status() == 0 ;
221		ok 59, $hash{"some key"} eq "some value";
222		ok 60, defined $hash{"some key"} ;
223		ok 61, (tied %hash)->status() == 0 ;
224		ok 62, exists $hash{"some key"} ;
225		ok 63, !defined $hash{"jimmy"} ;
226		ok 64, (tied %hash)->status() == DB_NOTFOUND ;
227		ok 65, !exists $hash{"jimmy"} ;
228		ok 66, (tied %hash)->status() == DB_NOTFOUND ;
	221	ok ((tied %hash)->status() == 0) ;
	222	ok $hash{"some key"} eq "some value";
	223	ok defined $hash{"some key"} ;
	224	ok ((tied %hash)->status() == 0) ;
	225	ok exists $hash{"some key"} ;
	226	ok !defined $hash{"jimmy"} ;
	227	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	228	ok !exists $hash{"jimmy"} ;
	229	ok ((tied %hash)->status() == DB_NOTFOUND) ;
229	230
230	231	delete $hash{"some key"} ;
231		ok 67, (tied %hash)->status() == 0 ;
232		ok 68, ! defined $hash{"some key"} ;
233		ok 69, (tied %hash)->status() == DB_NOTFOUND ;
234		ok 70, ! exists $hash{"some key"} ;
235		ok 71, (tied %hash)->status() == DB_NOTFOUND ;
	232	ok ((tied %hash)->status() == 0) ;
	233	ok ! defined $hash{"some key"} ;
	234	ok ((tied %hash)->status() == DB_NOTFOUND) ;
	235	ok ! exists $hash{"some key"} ;
	236	ok ((tied %hash)->status() == DB_NOTFOUND) ;
236	237
237	238	$hash{1} = 2 ;
238	239	$hash{10} = 20 ;

245	246	$values += $v ;
246	247	++ $count ;
247	248	}
248		ok 72, $count == 3 ;
249		ok 73, $keys == 1011 ;
250		ok 74, $values == 2022 ;
	249	ok $count == 3 ;
	250	ok $keys == 1011 ;
	251	ok $values == 2022 ;
251	252
252	253	# now clear the hash
253	254	%hash = () ;
254		ok 75, keys %hash == 0 ;
	255	ok keys %hash == 0 ;
255	256
256	257	untie %hash ;
257	258	}

263	264	my %hash ;
264	265	my $fd ;
265	266	my $value ;
266		ok 76, my $db = tie %hash, 'BerkeleyDB::Hash'
	267	ok my $db = tie %hash, 'BerkeleyDB::Hash'
267	268	or die $BerkeleyDB::Error;
268	269
269		ok 77, $db->db_put("some key", "some value") == 0 ;
270		ok 78, $db->db_get("some key", $value) == 0 ;
271		ok 79, $value eq "some value" ;
	270	ok $db->db_put("some key", "some value") == 0 ;
	271	ok $db->db_get("some key", $value) == 0 ;
	272	ok $value eq "some value" ;
272	273
273	274	undef $db ;
274	275	untie %hash ;

281	282	my $lex = new LexFile $Dfile ;
282	283	my %hash ;
283	284	my $value ;
284		ok 80, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	285	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
285	286	-Flags => DB_CREATE ;
286	287
287	288	# create some data

295	296	while (my ($k, $v) = each %data) {
296	297	$ret += $db->db_put($k, $v) ;
297	298	}
298		ok 81, $ret == 0 ;
	299	ok $ret == 0 ;
299	300
300	301
301	302	# do a partial get
302	303	my($pon, $off, $len) = $db->partial_set(0,2) ;
303		ok 82, $pon == 0 && $off == 0 && $len == 0 ;
304		ok 83, ( $db->db_get("red", $value) == 0) && $value eq "bo" ;
305		ok 84, ( $db->db_get("green", $value) == 0) && $value eq "ho" ;
306		ok 85, ( $db->db_get("blue", $value) == 0) && $value eq "se" ;
	304	ok $pon == 0 && $off == 0 && $len == 0 ;
	305	ok (( $db->db_get("red", $value) == 0) && $value eq "bo") ;
	306	ok (( $db->db_get("green", $value) == 0) && $value eq "ho") ;
	307	ok (( $db->db_get("blue", $value) == 0) && $value eq "se") ;
307	308
308	309	# do a partial get, off end of data
309	310	($pon, $off, $len) = $db->partial_set(3,2) ;
310		ok 86, $pon ;
311		ok 87, $off == 0 ;
312		ok 88, $len == 2 ;
313		ok 89, $db->db_get("red", $value) == 0 && $value eq "t" ;
314		ok 90, $db->db_get("green", $value) == 0 && $value eq "se" ;
315		ok 91, $db->db_get("blue", $value) == 0 && $value eq "" ;
	311	ok $pon ;
	312	ok $off == 0 ;
	313	ok $len == 2 ;
	314	ok $db->db_get("red", $value) == 0 && $value eq "t" ;
	315	ok $db->db_get("green", $value) == 0 && $value eq "se" ;
	316	ok $db->db_get("blue", $value) == 0 && $value eq "" ;
316	317
317	318	# switch of partial mode
318	319	($pon, $off, $len) = $db->partial_clear() ;
319		ok 92, $pon ;
320		ok 93, $off == 3 ;
321		ok 94, $len == 2 ;
322		ok 95, $db->db_get("red", $value) == 0 && $value eq "boat" ;
323		ok 96, $db->db_get("green", $value) == 0 && $value eq "house" ;
324		ok 97, $db->db_get("blue", $value) == 0 && $value eq "sea" ;
	320	ok $pon ;
	321	ok $off == 3 ;
	322	ok $len == 2 ;
	323	ok $db->db_get("red", $value) == 0 && $value eq "boat" ;
	324	ok $db->db_get("green", $value) == 0 && $value eq "house" ;
	325	ok $db->db_get("blue", $value) == 0 && $value eq "sea" ;
325	326
326	327	# now partial put
327	328	($pon, $off, $len) = $db->partial_set(0,2) ;
328		ok 98, ! $pon ;
329		ok 99, $off == 0 ;
330		ok 100, $len == 0 ;
331		ok 101, $db->db_put("red", "") == 0 ;
332		ok 102, $db->db_put("green", "AB") == 0 ;
333		ok 103, $db->db_put("blue", "XYZ") == 0 ;
334		ok 104, $db->db_put("new", "KLM") == 0 ;
	329	ok ! $pon ;
	330	ok $off == 0 ;
	331	ok $len == 0 ;
	332	ok $db->db_put("red", "") == 0 ;
	333	ok $db->db_put("green", "AB") == 0 ;
	334	ok $db->db_put("blue", "XYZ") == 0 ;
	335	ok $db->db_put("new", "KLM") == 0 ;
335	336
336	337	$db->partial_clear() ;
337		ok 105, $db->db_get("red", $value) == 0 && $value eq "at" ;
338		ok 106, $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
339		ok 107, $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
340		ok 108, $db->db_get("new", $value) == 0 && $value eq "KLM" ;
	338	ok $db->db_get("red", $value) == 0 && $value eq "at" ;
	339	ok $db->db_get("green", $value) == 0 && $value eq "ABuse" ;
	340	ok $db->db_get("blue", $value) == 0 && $value eq "XYZa" ;
	341	ok $db->db_get("new", $value) == 0 && $value eq "KLM" ;
341	342
342	343	# now partial put
343	344	$db->partial_set(3,2) ;
344		ok 109, $db->db_put("red", "PPP") == 0 ;
345		ok 110, $db->db_put("green", "Q") == 0 ;
346		ok 111, $db->db_put("blue", "XYZ") == 0 ;
347		ok 112, $db->db_put("new", "--") == 0 ;
	345	ok $db->db_put("red", "PPP") == 0 ;
	346	ok $db->db_put("green", "Q") == 0 ;
	347	ok $db->db_put("blue", "XYZ") == 0 ;
	348	ok $db->db_put("new", "--") == 0 ;
348	349
349	350	($pon, $off, $len) = $db->partial_clear() ;
350		ok 113, $pon ;
351		ok 114, $off == 3 ;
352		ok 115, $len == 2 ;
353		ok 116, $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
354		ok 117, $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
355		ok 118, $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
356		ok 119, $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
	351	ok $pon ;
	352	ok $off == 3 ;
	353	ok $len == 2 ;
	354	ok $db->db_get("red", $value) == 0 && $value eq "at\0PPP" ;
	355	ok $db->db_get("green", $value) == 0 && $value eq "ABuQ" ;
	356	ok $db->db_get("blue", $value) == 0 && $value eq "XYZXYZ" ;
	357	ok $db->db_get("new", $value) == 0 && $value eq "KLM--" ;
357	358	}
358	359
359	360	{

363	364	my $lex = new LexFile $Dfile ;
364	365	my %hash ;
365	366	my $value ;
366		ok 120, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	367	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
367	368	-Flags => DB_CREATE ;
368	369
369	370	# create some data

380	381
381	382	# do a partial get
382	383	$db->partial_set(0,2) ;
383		ok 121, $hash{"red"} eq "bo" ;
384		ok 122, $hash{"green"} eq "ho" ;
385		ok 123, $hash{"blue"} eq "se" ;
	384	ok $hash{"red"} eq "bo" ;
	385	ok $hash{"green"} eq "ho" ;
	386	ok $hash{"blue"} eq "se" ;
386	387
387	388	# do a partial get, off end of data
388	389	$db->partial_set(3,2) ;
389		ok 124, $hash{"red"} eq "t" ;
390		ok 125, $hash{"green"} eq "se" ;
391		ok 126, $hash{"blue"} eq "" ;
	390	ok $hash{"red"} eq "t" ;
	391	ok $hash{"green"} eq "se" ;
	392	ok $hash{"blue"} eq "" ;
392	393
393	394	# switch of partial mode
394	395	$db->partial_clear() ;
395		ok 127, $hash{"red"} eq "boat" ;
396		ok 128, $hash{"green"} eq "house" ;
397		ok 129, $hash{"blue"} eq "sea" ;
	396	ok $hash{"red"} eq "boat" ;
	397	ok $hash{"green"} eq "house" ;
	398	ok $hash{"blue"} eq "sea" ;
398	399
399	400	# now partial put
400	401	$db->partial_set(0,2) ;
401		ok 130, $hash{"red"} = "" ;
402		ok 131, $hash{"green"} = "AB" ;
403		ok 132, $hash{"blue"} = "XYZ" ;
404		ok 133, $hash{"new"} = "KLM" ;
	402	ok $hash{"red"} = "" ;
	403	ok $hash{"green"} = "AB" ;
	404	ok $hash{"blue"} = "XYZ" ;
	405	ok $hash{"new"} = "KLM" ;
405	406
406	407	$db->partial_clear() ;
407		ok 134, $hash{"red"} eq "at" ;
408		ok 135, $hash{"green"} eq "ABuse" ;
409		ok 136, $hash{"blue"} eq "XYZa" ;
410		ok 137, $hash{"new"} eq "KLM" ;
	408	ok $hash{"red"} eq "at" ;
	409	ok $hash{"green"} eq "ABuse" ;
	410	ok $hash{"blue"} eq "XYZa" ;
	411	ok $hash{"new"} eq "KLM" ;
411	412
412	413	# now partial put
413	414	$db->partial_set(3,2) ;
414		ok 138, $hash{"red"} = "PPP" ;
415		ok 139, $hash{"green"} = "Q" ;
416		ok 140, $hash{"blue"} = "XYZ" ;
417		ok 141, $hash{"new"} = "TU" ;
	415	ok $hash{"red"} = "PPP" ;
	416	ok $hash{"green"} = "Q" ;
	417	ok $hash{"blue"} = "XYZ" ;
	418	ok $hash{"new"} = "TU" ;
418	419
419	420	$db->partial_clear() ;
420		ok 142, $hash{"red"} eq "at\0PPP" ;
421		ok 143, $hash{"green"} eq "ABuQ" ;
422		ok 144, $hash{"blue"} eq "XYZXYZ" ;
423		ok 145, $hash{"new"} eq "KLMTU" ;
	421	ok $hash{"red"} eq "at\0PPP" ;
	422	ok $hash{"green"} eq "ABuQ" ;
	423	ok $hash{"blue"} eq "XYZXYZ" ;
	424	ok $hash{"new"} eq "KLMTU" ;
424	425	}
425	426
426	427	{

431	432	my $value ;
432	433
433	434	my $home = "./fred" ;
434		ok 146, my $lexD = new LexDir($home);
435		ok 147, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	435	ok my $lexD = new LexDir($home);
	436	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
436	437	-Flags => DB_CREATE\|DB_INIT_TXN\|
437	438	DB_INIT_MPOOL\|DB_INIT_LOCK ;
438		ok 148, my $txn = $env->txn_begin() ;
439		ok 149, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	439	ok my $txn = $env->txn_begin() ;
	440	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
440	441	-Flags => DB_CREATE ,
441	442	-Env => $env,
442	443	-Txn => $txn ;
443	444
444	445
445		ok 150, $txn->txn_commit() == 0 ;
446		ok 151, $txn = $env->txn_begin() ;
	446	ok $txn->txn_commit() == 0 ;
	447	ok $txn = $env->txn_begin() ;
447	448	$db1->Txn($txn);
448	449	# create some data
449	450	my %data = (

456	457	while (my ($k, $v) = each %data) {
457	458	$ret += $db1->db_put($k, $v) ;
458	459	}
459		ok 152, $ret == 0 ;
	460	ok $ret == 0 ;
460	461
461	462	# should be able to see all the records
462	463
463		ok 153, my $cursor = $db1->db_cursor() ;
	464	ok my $cursor = $db1->db_cursor() ;
464	465	my ($k, $v) = ("", "") ;
465	466	my $count = 0 ;
466	467	# sequence forwards
467	468	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
468	469	++ $count ;
469	470	}
470		ok 154, $count == 3 ;
	471	ok $count == 3 ;
471	472	undef $cursor ;
472	473
473	474	# now abort the transaction
474		ok 155, $txn->txn_abort() == 0 ;
	475	ok $txn->txn_abort() == 0 ;
475	476
476	477	# there shouldn't be any records in the database
477	478	$count = 0 ;
478	479	# sequence forwards
479		ok 156, $cursor = $db1->db_cursor() ;
	480	ok $cursor = $db1->db_cursor() ;
480	481	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
481	482	++ $count ;
482	483	}
483		ok 157, $count == 0 ;
	484	ok $count == 0 ;
484	485
485	486	undef $txn ;
486	487	undef $cursor ;

495	496
496	497	my $lex = new LexFile $Dfile ;
497	498	my %hash ;
498		ok 158, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	499	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
499	500	-Property => DB_DUP,
500	501	-Flags => DB_CREATE ;
501	502

506	507	$hash{'Wall'} = 'Brick' ;
507	508	$hash{'mouse'} = 'mickey' ;
508	509
509		ok 159, keys %hash == 6 ;
	510	ok keys %hash == 6 ;
510	511
511	512	# create a cursor
512		ok 160, my $cursor = $db->db_cursor() ;
	513	ok my $cursor = $db->db_cursor() ;
513	514
514	515	my $key = "Wall" ;
515	516	my $value ;
516		ok 161, $cursor->c_get($key, $value, DB_SET) == 0 ;
517		ok 162, $key eq "Wall" && $value eq "Larry" ;
518		ok 163, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
519		ok 164, $key eq "Wall" && $value eq "Stone" ;
520		ok 165, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
521		ok 166, $key eq "Wall" && $value eq "Brick" ;
522		ok 167, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
523		ok 168, $key eq "Wall" && $value eq "Brick" ;
	517	ok $cursor->c_get($key, $value, DB_SET) == 0 ;
	518	ok $key eq "Wall" && $value eq "Larry" ;
	519	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	520	ok $key eq "Wall" && $value eq "Stone" ;
	521	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	522	ok $key eq "Wall" && $value eq "Brick" ;
	523	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	524	ok $key eq "Wall" && $value eq "Brick" ;
524	525
525	526	#my $ref = $db->db_stat() ;
526		#ok 143, $ref->{bt_flags} \| DB_DUP ;
	527	#ok $ref->{bt_flags} \| DB_DUP ;
527	528
528	529	# test DB_DUP_NEXT
529	530	my ($k, $v) = ("Wall", "") ;
530		ok 169, $cursor->c_get($k, $v, DB_SET) == 0 ;
531		ok 170, $k eq "Wall" && $v eq "Larry" ;
532		ok 171, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
533		ok 172, $k eq "Wall" && $v eq "Stone" ;
534		ok 173, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
535		ok 174, $k eq "Wall" && $v eq "Brick" ;
536		ok 175, $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
537		ok 176, $k eq "Wall" && $v eq "Brick" ;
538		ok 177, $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
	531	ok $cursor->c_get($k, $v, DB_SET) == 0 ;
	532	ok $k eq "Wall" && $v eq "Larry" ;
	533	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
	534	ok $k eq "Wall" && $v eq "Stone" ;
	535	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
	536	ok $k eq "Wall" && $v eq "Brick" ;
	537	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
	538	ok $k eq "Wall" && $v eq "Brick" ;
	539	ok $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
539	540
540	541
541	542	undef $db ;

552	553	my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
553	554	my @Values = qw( 1 11 3 dd x abc 2 0 ) ;
554	555
555		ok 178, tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
	556	ok tie %h, "BerkeleyDB::Hash", -Filename => $Dfile,
556	557	-DupCompare => sub { $_[0] cmp $_[1] },
557	558	-Property => DB_DUP\|DB_DUPSORT,
558	559	-Flags => DB_CREATE ;
559	560
560		ok 179, tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
	561	ok tie %g, 'BerkeleyDB::Hash', -Filename => $Dfile2,
561	562	-DupCompare => sub { $_[0] <=> $_[1] },
562	563	-Property => DB_DUP\|DB_DUPSORT,
563	564	-Flags => DB_CREATE ;

569	570	$g{$_} = $value ;
570	571	}
571	572
572		ok 180, my $cursor = (tied %h)->db_cursor() ;
	573	ok my $cursor = (tied %h)->db_cursor() ;
573	574	$key = 9 ; $value = "";
574		ok 181, $cursor->c_get($key, $value, DB_SET) == 0 ;
575		ok 182, $key == 9 && $value eq 11 ;
576		ok 183, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
577		ok 184, $key == 9 && $value == 2 ;
578		ok 185, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
579		ok 186, $key == 9 && $value eq "x" ;
	575	ok $cursor->c_get($key, $value, DB_SET) == 0 ;
	576	ok $key == 9 && $value eq 11 ;
	577	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	578	ok $key == 9 && $value == 2 ;
	579	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	580	ok $key == 9 && $value eq "x" ;
580	581
581	582	$cursor = (tied %g)->db_cursor() ;
582	583	$key = 9 ;
583		ok 187, $cursor->c_get($key, $value, DB_SET) == 0 ;
584		ok 188, $key == 9 && $value eq "x" ;
585		ok 189, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
586		ok 190, $key == 9 && $value == 2 ;
587		ok 191, $cursor->c_get($key, $value, DB_NEXT) == 0 ;
588		ok 192, $key == 9 && $value == 11 ;
	584	ok $cursor->c_get($key, $value, DB_SET) == 0 ;
	585	ok $key == 9 && $value eq "x" ;
	586	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	587	ok $key == 9 && $value == 2 ;
	588	ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
	589	ok $key == 9 && $value == 11 ;
589	590
590	591
591	592	}

595	596	my $lex = new LexFile $Dfile;
596	597	my %hh ;
597	598
598		ok 193, my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
	599	ok my $YY = tie %hh, "BerkeleyDB::Hash", -Filename => $Dfile,
599	600	-DupCompare => sub { $_[0] cmp $_[1] },
600	601	-Property => DB_DUP,
601	602	-Flags => DB_CREATE ;

607	608	$hh{'mouse'} = 'mickey' ;
608	609
609	610	# first work in scalar context
610		ok 194, scalar $YY->get_dup('Unknown') == 0 ;
611		ok 195, scalar $YY->get_dup('Smith') == 1 ;
612		ok 196, scalar $YY->get_dup('Wall') == 3 ;
	611	ok scalar $YY->get_dup('Unknown') == 0 ;
	612	ok scalar $YY->get_dup('Smith') == 1 ;
	613	ok scalar $YY->get_dup('Wall') == 3 ;
613	614
614	615	# now in list context
615	616	my @unknown = $YY->get_dup('Unknown') ;
616		ok 197, "@unknown" eq "" ;
	617	ok "@unknown" eq "" ;
617	618
618	619	my @smith = $YY->get_dup('Smith') ;
619		ok 198, "@smith" eq "John" ;
	620	ok "@smith" eq "John" ;
620	621
621	622	{
622	623	my @wall = $YY->get_dup('Wall') ;
623	624	my %wall ;
624	625	@wall{@wall} = @wall ;
625		ok 199, (@wall == 3 && $wall{'Larry'}
	626	ok (@wall == 3 && $wall{'Larry'}
626	627	&& $wall{'Stone'} && $wall{'Brick'});
627	628	}
628	629
629	630	# hash
630	631	my %unknown = $YY->get_dup('Unknown', 1) ;
631		ok 200, keys %unknown == 0 ;
	632	ok keys %unknown == 0 ;
632	633
633	634	my %smith = $YY->get_dup('Smith', 1) ;
634		ok 201, keys %smith == 1 && $smith{'John'} ;
	635	ok keys %smith == 1 && $smith{'John'} ;
635	636
636	637	my %wall = $YY->get_dup('Wall', 1) ;
637		ok 202, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
	638	ok keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
638	639	&& $wall{'Brick'} == 1 ;
639	640
640	641	undef $YY ;

688	689
689	690	close FILE ;
690	691
	692	use Test::More;
691	693	BEGIN { push @INC, '.'; }
692	694	eval 'use SubDB ; ';
693		main::ok 203, $@ eq "" ;
	695	ok $@ eq "" ;
694	696	my %h ;
695	697	my $X ;
696	698	eval '

699	701	-Mode => 0640 );
700	702	' ;
701	703
702		main::ok 204, $@ eq "" ;
	704	ok $@ eq "" ;
703	705
704	706	my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
705		main::ok 205, $@ eq "" ;
706		main::ok 206, $ret == 7 ;
	707	ok $@ eq "" ;
	708	ok $ret == 7 ;
707	709
708	710	my $value = 0;
709	711	$ret = eval '$X->db_put("joe", 4) ; $X->db_get("joe", $value) ; return $value' ;
710		main::ok 207, $@ eq "" ;
711		main::ok 208, $ret == 10 ;
	712	ok $@ eq "" ;
	713	ok $ret == 10 ;
712	714
713	715	$ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
714		main::ok 209, $@ eq "" ;
715		main::ok 210, $ret == 1 ;
	716	ok $@ eq "" ;
	717	ok $ret == 1 ;
716	718
717	719	$ret = eval '$X->A_new_method("joe") ' ;
718		main::ok 211, $@ eq "" ;
719		main::ok 212, $ret eq "[[10]]" ;
	720	ok $@ eq "" ;
	721	ok $ret eq "[[10]]" ;
720	722
721	723	unlink "SubDB.pm", "dbhash.tmp" ;
722	724

+52

-53

t/join.t less more

6	6	use lib 't';
7	7	use BerkeleyDB;
8	8	use util ;
9
10		if ($BerkeleyDB::db_ver < 2.005002)
11		{
12		print "1..0 # Skip: join needs Berkeley DB 2.5.2 or later\n" ;
13		exit 0 ;
	9	use Test::More;
	10
	11	BEGIN {
	12	plan(skip_all => "this needs BerkeleyDB 2.5.2 or better" )
	13	if $BerkeleyDB::db_ver < 2.005002;
	14
	15	plan tests => 42;
14	16	}
15
16
17		print "1..42\n";
18	17
19	18	my $Dfile1 = "dbhash1.tmp";
20	19	my $Dfile2 = "dbhash2.tmp";

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

39	38
40	39	# no cursors supplied
41	40	eval '$cursor = $db1->db_join() ;' ;
42		ok 2, $@ =~ /Usage: \$db->BerkeleyDB::db_join\Q([cursors], flags=0)/;
	41	ok $@ =~ /Usage: \$db->BerkeleyDB::db_join\Q([cursors], flags=0)/;
43	42
44	43	# empty list
45	44	eval '$cursor = $db1->db_join([]) ;' ;
46		ok 3, $@ =~ /db_join: No cursors in parameter list/;
	45	ok $@ =~ /db_join: No cursors in parameter list/;
47	46
48	47	# cursor list, isn not a []
49	48	eval '$cursor = $db1->db_join({}) ;' ;
50		ok 4, $@ =~ /db_join: first parameter is not an array reference/;
	49	ok $@ =~ /db_join: first parameter is not an array reference/;
51	50
52	51	eval '$cursor = $db1->db_join(\1) ;' ;
53		ok 5, $@ =~ /db_join: first parameter is not an array reference/;
	52	ok $@ =~ /db_join: first parameter is not an array reference/;
54	53
55	54	my ($a, $b) = ("a", "b");
56	55	$a = bless [], "fred";
57	56	$b = bless [], "fred";
58	57	eval '$cursor = $db1->db_join($a, $b) ;' ;
59		ok 6, $@ =~ /db_join: first parameter is not an array reference/;
	58	ok $@ =~ /db_join: first parameter is not an array reference/;
60	59
61	60	}
62	61

72	71
73	72	my $home = "./fred7" ;
74	73	rmtree $home;
75		ok 7, ! -d $home;
76		ok 8, my $lexD = new LexDir($home);
77		ok 9, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	74	ok ! -d $home;
	75	ok my $lexD = new LexDir($home);
	76	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
78	77	-Flags => DB_CREATE\|DB_INIT_TXN
79	78	\|DB_INIT_MPOOL;
80	79	#\|DB_INIT_MPOOL\| DB_INIT_LOCK;
81		ok 10, my $txn = $env->txn_begin() ;
82		ok 11, my $db1 = tie %hash1, 'BerkeleyDB::Hash',
	80	ok my $txn = $env->txn_begin() ;
	81	ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
83	82	-Filename => $Dfile1,
84	83	-Flags => DB_CREATE,
85	84	-DupCompare => sub { $_[0] cmp $_[1] },

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

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

105	104	-Txn => $txn ;
106	105
107	106
108		ok 14, addData($db1, qw( apple Convenience
	107	ok addData($db1, qw( apple Convenience
109	108	peach Shopway
110	109	pear Farmer
111	110	raspberry Shopway

114	113	blueberry Farmer
115	114	));
116	115
117		ok 15, addData($db2, qw( red apple
	116	ok addData($db2, qw( red apple
118	117	red raspberry
119	118	red strawberry
120	119	yellow peach

122	121	green gooseberry
123	122	blue blueberry)) ;
124	123
125		ok 16, addData($db3, qw( expensive apple
	124	ok addData($db3, qw( expensive apple
126	125	reasonable raspberry
127	126	expensive strawberry
128	127	reasonable peach

130	129	expensive gooseberry
131	130	reasonable blueberry)) ;
132	131
133		ok 17, my $cursor2 = $db2->db_cursor() ;
	132	ok my $cursor2 = $db2->db_cursor() ;
134	133	my $k = "red" ;
135	134	my $v = "" ;
136		ok 18, $cursor2->c_get($k, $v, DB_SET) == 0 ;
	135	ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
137	136
138	137	# Two way Join
139		ok 19, my $cursor1 = $db1->db_join([$cursor2]) ;
	138	ok my $cursor1 = $db1->db_join([$cursor2]) ;
140	139
141	140	my %expected = qw( apple Convenience
142	141	raspberry Shopway

149	148	if defined $expected{$k} && $expected{$k} eq $v ;
150	149	#print "[$k] [$v]\n" ;
151	150	}
152		ok 20, keys %expected == 0 ;
153		ok 21, $cursor1->status() == DB_NOTFOUND ;
	151	is keys %expected, 0 ;
	152	ok $cursor1->status() == DB_NOTFOUND ;
154	153
155	154	# Three way Join
156		ok 22, $cursor2 = $db2->db_cursor() ;
	155	ok $cursor2 = $db2->db_cursor() ;
157	156	$k = "red" ;
158	157	$v = "" ;
159		ok 23, $cursor2->c_get($k, $v, DB_SET) == 0 ;
160
161		ok 24, my $cursor3 = $db3->db_cursor() ;
	158	ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
	159
	160	ok my $cursor3 = $db3->db_cursor() ;
162	161	$k = "expensive" ;
163	162	$v = "" ;
164		ok 25, $cursor3->c_get($k, $v, DB_SET) == 0 ;
165		ok 26, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
	163	ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
	164	ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
166	165
167	166	%expected = qw( apple Convenience
168	167	strawberry Shopway

174	173	if defined $expected{$k} && $expected{$k} eq $v ;
175	174	#print "[$k] [$v]\n" ;
176	175	}
177		ok 27, keys %expected == 0 ;
178		ok 28, $cursor1->status() == DB_NOTFOUND ;
	176	is keys %expected, 0 ;
	177	ok $cursor1->status() == DB_NOTFOUND ;
179	178
180	179	# test DB_JOIN_ITEM
181	180	# #################
182		ok 29, $cursor2 = $db2->db_cursor() ;
	181	ok $cursor2 = $db2->db_cursor() ;
183	182	$k = "red" ;
184	183	$v = "" ;
185		ok 30, $cursor2->c_get($k, $v, DB_SET) == 0 ;
	184	ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
186	185
187		ok 31, $cursor3 = $db3->db_cursor() ;
	186	ok $cursor3 = $db3->db_cursor() ;
188	187	$k = "expensive" ;
189	188	$v = "" ;
190		ok 32, $cursor3->c_get($k, $v, DB_SET) == 0 ;
191		ok 33, $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
	189	ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
	190	ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
192	191
193	192	%expected = qw( apple 1
194	193	strawberry 1

202	201	if defined $expected{$k} ;
203	202	#print "[$k]\n" ;
204	203	}
205		ok 34, keys %expected == 0 ;
206		ok 35, $cursor1->status() == DB_NOTFOUND ;
207
208		ok 36, $cursor1->c_close() == 0 ;
209		ok 37, $cursor2->c_close() == 0 ;
210		ok 38, $cursor3->c_close() == 0 ;
211
212		ok 39, ($status = $txn->txn_commit()) == 0;
	204	is keys %expected, 0 ;
	205	ok $cursor1->status() == DB_NOTFOUND ;
	206
	207	ok $cursor1->c_close() == 0 ;
	208	ok $cursor2->c_close() == 0 ;
	209	ok $cursor3->c_close() == 0 ;
	210
	211	ok (($status = $txn->txn_commit()) == 0);
213	212
214	213	undef $txn ;
215	214
216		ok 40, my $cursor1a = $db1->db_cursor() ;
	215	ok my $cursor1a = $db1->db_cursor() ;
217	216	eval { $cursor1 = $db1->db_join([$cursor1a]) };
218		ok 41, $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
	217	ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
219	218	eval { $cursor1 = $db1->db_join([$cursor1]) } ;
220		ok 42, $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
	219	ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
221	220
222	221	undef $cursor1a;
223	222	#undef $cursor1;

+23

-24

t/mldbm.t less more

1	1
2	2	use strict ;
3	3
	4	use lib 't';
	5	use Test::More ;
	6
4	7	BEGIN
5	8	{
6		if ($] < 5.005) {
7		print "1..0 # Skip: this is Perl $], skipping test\n" ;
8		exit 0 ;
9		}
	9	plan skip_all => "this is Perl $], skipping test\n"
	10	if $] < 5.005 ;
10	11
11	12	eval { require Data::Dumper ; };
12	13	if ($@) {
13		print "1..0 # Skip: Data::Dumper is not installed on this system.\n";
14		exit 0 ;
	14	plan skip_all => "Data::Dumper is not installed on this system.\n";
15	15	}
16	16	{
17	17	local ($^W) = 0 ;
18	18	if ($Data::Dumper::VERSION < 2.08) {
19		print "1..0 # Skip: Data::Dumper 2.08 or better required (found $Data::Dumper::VERSION).\n";
20		exit 0 ;
	19	plan skip_all => "Data::Dumper 2.08 or better required (found $Data::Dumper::VERSION).\n";
21	20	}
22	21	}
23	22	eval { require MLDBM ; };
24	23	if ($@) {
25		print "1..0 # Skip: MLDBM is not installed on this system.\n";
26		exit 0 ;
	24	plan skip_all => "MLDBM is not installed on this system.\n";
27	25	}
	26
	27	plan tests => 12;
28	28	}
29	29
30	30	use lib 't' ;
31	31	use util ;
32
33		print "1..12\n";
34	32
35	33	{
36	34	package BTREE ;

38	36	use BerkeleyDB ;
39	37	use MLDBM qw(BerkeleyDB::Btree) ;
40	38	use Data::Dumper;
	39	use Test::More;
41	40
42	41	my $filename = "";
43	42	my $lex = new LexFile $filename;

47	46	my $db = tie %o, 'MLDBM', -Filename => $filename,
48	47	-Flags => DB_CREATE
49	48	or die $!;
50		::ok 1, $db ;
51		::ok 2, $db->type() == DB_BTREE ;
	49	ok $db ;
	50	ok $db->type() == DB_BTREE ;
52	51
53	52	my $c = [\'c'];
54	53	my $b = {};

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

86	85	my $db = tie %o, 'MLDBM', -Filename => $filename,
87	86	-Flags => DB_CREATE
88	87	or die $!;
89		::ok 7, $db ;
90		::ok 8, $db->type() == DB_HASH ;
	88	::ok $db ;
	89	::ok $db->type() == DB_HASH ;
91	90
92	91
93	92	my $c = [\'c'];

102	101	$o{f} = 1024.1024;
103	102
104	103	my $struct = [@o{qw(a b c)}];
105		::ok 9, ::_compare([$a, $b, $c], $struct);
106		::ok 10, $o{d} eq "{once upon a time}" ;
107		::ok 11, $o{e} == 1024 ;
108		::ok 12, $o{f} eq 1024.1024 ;
	104	::ok ::_compare([$a, $b, $c], $struct);
	105	::ok $o{d} eq "{once upon a time}" ;
	106	::ok $o{e} == 1024 ;
	107	::ok $o{f} eq 1024.1024 ;
109	108
110	109	}

+12

-11

t/queue.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use Test::More;
9		use util(1) ;
	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;

645	645
646	646	close FILE ;
647	647
	648	use Test::More;
648	649	BEGIN { push @INC, '.'; }
649	650	eval 'use SubDB ; ';
650		main::ok $@ eq "" ;
	651	ok $@ eq "" ;
651	652	my @h ;
652	653	my $X ;
653	654	my $rec_len = 34 ;

660	661	);
661	662	' ;
662	663
663		main::ok $@ eq "" ;
	664	ok $@ eq "" ;
664	665
665	666	my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
666		main::ok $@ eq "" ;
667		main::ok $ret == 7 ;
	667	ok $@ eq "" ;
	668	ok $ret == 7 ;
668	669
669	670	my $value = 0;
670	671	$ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
671		main::ok $@ eq "" ;
672		main::ok $ret == 10 ;
	672	ok $@ eq "" ;
	673	ok $ret == 10 ;
673	674
674	675	$ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
675		main::ok $@ eq "" ;
676		main::ok $ret == 1 ;
	676	ok $@ eq "" ;
	677	ok $ret == 1 ;
677	678
678	679	$ret = eval '$X->A_new_method(1) ' ;
679		main::ok $@ eq "" ;
680		main::ok $ret eq "[[10]]" ;
	680	ok $@ eq "" ;
	681	ok $ret eq "[[10]]" ;
681	682
682	683	undef $X ;
683	684	untie @h ;

+240

-238

t/recno.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		print "1..226\n";
	9	use Test::More;
	10
	11	plan tests => 225;
11	12
12	13	my $Dfile = "dbhash.tmp";
13	14	my $Dfile2 = "dbhash2.tmp";

21	22	# Check for invalid parameters
22	23	my $db ;
23	24	eval ' $db = new BerkeleyDB::Recno -Stupid => 3 ; ' ;
24		ok 1, $@ =~ /unknown key value$s$ Stupid/ ;
	25	ok $@ =~ /unknown key value$s$ Stupid/ ;
25	26
26	27	eval ' $db = new BerkeleyDB::Recno -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
27		ok 2, $@ =~ /unknown key value$s$ / ;
	28	ok $@ =~ /unknown key value$s$ / ;
28	29
29	30	eval ' $db = new BerkeleyDB::Recno -Env => 2 ' ;
30		ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	31	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
31	32
32	33	eval ' $db = new BerkeleyDB::Recno -Txn => "x" ' ;
33		ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
	34	ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
34	35
35	36	my $obj = bless [], "main" ;
36	37	eval ' $db = new BerkeleyDB::Recno -Env => $obj ' ;
37		ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	38	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
38	39	}
39	40
40	41	# Now check the interface to Recno

42	43	{
43	44	my $lex = new LexFile $Dfile ;
44	45
45		ok 6, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	46	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
46	47	-Flags => DB_CREATE ;
47	48
48	49	# Add a k/v pair
49	50	my $value ;
50	51	my $status ;
51		ok 7, $db->db_put(1, "some value") == 0 ;
52		ok 8, $db->status() == 0 ;
53		ok 9, $db->db_get(1, $value) == 0 ;
54		ok 10, $value eq "some value" ;
55		ok 11, $db->db_put(2, "value") == 0 ;
56		ok 12, $db->db_get(2, $value) == 0 ;
57		ok 13, $value eq "value" ;
58		ok 14, $db->db_del(1) == 0 ;
59		ok 15, ($status = $db->db_get(1, $value)) == DB_KEYEMPTY ;
60		ok 16, $db->status() == DB_KEYEMPTY ;
61		ok 17, $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
62
63		ok 18, ($status = $db->db_get(7, $value)) == DB_NOTFOUND ;
64		ok 19, $db->status() == DB_NOTFOUND ;
65		ok 20, $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
66
67		ok 21, $db->db_sync() == 0 ;
	52	ok $db->db_put(1, "some value") == 0 ;
	53	ok $db->status() == 0 ;
	54	ok $db->db_get(1, $value) == 0 ;
	55	ok $value eq "some value" ;
	56	ok $db->db_put(2, "value") == 0 ;
	57	ok $db->db_get(2, $value) == 0 ;
	58	ok $value eq "value" ;
	59	ok $db->db_del(1) == 0 ;
	60	ok (($status = $db->db_get(1, $value)) == DB_KEYEMPTY) ;
	61	ok $db->status() == DB_KEYEMPTY ;
	62	ok $db->status() eq $DB_errors{'DB_KEYEMPTY'} ;
	63
	64	ok (($status = $db->db_get(7, $value)) == DB_NOTFOUND) ;
	65	ok $db->status() == DB_NOTFOUND ;
	66	ok $db->status() eq $DB_errors{'DB_NOTFOUND'} ;
	67
	68	ok $db->db_sync() == 0 ;
68	69
69	70	# Check NOOVERWRITE will make put fail when attempting to overwrite
70	71	# an existing record.
71	72
72		ok 22, $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
73		ok 23, $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
74		ok 24, $db->status() == DB_KEYEXIST ;
	73	ok $db->db_put( 2, 'x', DB_NOOVERWRITE) == DB_KEYEXIST ;
	74	ok $db->status() eq $DB_errors{'DB_KEYEXIST'} ;
	75	ok $db->status() == DB_KEYEXIST ;
75	76
76	77
77	78	# check that the value of the key has not been changed by the
78	79	# previous test
79		ok 25, $db->db_get(2, $value) == 0 ;
80		ok 26, $value eq "value" ;
	80	ok $db->db_get(2, $value) == 0 ;
	81	ok $value eq "value" ;
81	82
82	83
83	84	}

88	89	my $lex = new LexFile $Dfile ;
89	90
90	91	my $home = "./fred" ;
91		ok 27, my $lexD = new LexDir($home);
92
93		ok 28, my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,@StdErrFile,
	92	ok my $lexD = new LexDir($home);
	93
	94	ok my $env = new BerkeleyDB::Env -Flags => DB_CREATE\|DB_INIT_MPOOL,@StdErrFile,
94	95	-Home => $home ;
95	96
96		ok 29, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	97	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
97	98	-Env => $env,
98	99	-Flags => DB_CREATE ;
99	100
100	101	# Add a k/v pair
101	102	my $value ;
102		ok 30, $db->db_put(1, "some value") == 0 ;
103		ok 31, $db->db_get(1, $value) == 0 ;
104		ok 32, $value eq "some value" ;
	103	ok $db->db_put(1, "some value") == 0 ;
	104	ok $db->db_get(1, $value) == 0 ;
	105	ok $value eq "some value" ;
105	106	undef $db ;
106	107	undef $env ;
107	108	}

113	114	my $lex = new LexFile $Dfile ;
114	115	my @array ;
115	116	my ($k, $v) ;
116		ok 33, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	117	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
117	118	-ArrayBase => 0,
118	119	-Flags => DB_CREATE ;
119	120

131	132	$ret += $db->db_put($i, $data[$i]) ;
132	133	$data{$i} = $data[$i] ;
133	134	}
134		ok 34, $ret == 0 ;
	135	ok $ret == 0 ;
135	136
136	137	# create the cursor
137		ok 35, my $cursor = $db->db_cursor() ;
	138	ok my $cursor = $db->db_cursor() ;
138	139
139	140	$k = 0 ; $v = "" ;
140	141	my %copy = %data;

148	149	{ ++ $extras }
149	150	}
150	151
151		ok 36, $cursor->status() == DB_NOTFOUND ;
152		ok 37, $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
153		ok 38, keys %copy == 0 ;
154		ok 39, $extras == 0 ;
	152	ok $cursor->status() == DB_NOTFOUND ;
	153	ok $cursor->status() eq $DB_errors{'DB_NOTFOUND'} ;
	154	ok keys %copy == 0 ;
	155	ok $extras == 0 ;
155	156
156	157	# sequence backwards
157	158	%copy = %data ;

165	166	else
166	167	{ ++ $extras }
167	168	}
168		ok 40, $status == DB_NOTFOUND ;
169		ok 41, $status eq $DB_errors{'DB_NOTFOUND'} ;
170		ok 42, $cursor->status() == $status ;
171		ok 43, $cursor->status() eq $status ;
172		ok 44, keys %copy == 0 ;
173		ok 45, $extras == 0 ;
	169	ok $status == DB_NOTFOUND ;
	170	ok $status eq $DB_errors{'DB_NOTFOUND'} ;
	171	ok $cursor->status() == $status ;
	172	ok $cursor->status() eq $status ;
	173	ok keys %copy == 0 ;
	174	ok $extras == 0 ;
174	175	}
175	176
176	177	{

180	181	my $lex = new LexFile $Dfile ;
181	182	my @array ;
182	183	my $db ;
183		ok 46, $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	184	ok $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
184	185	-Property => DB_RENUMBER,
185	186	-ArrayBase => 0,
186		-Flags => DB_CREATE ;
187
188		ok 47, my $cursor = (tied @array)->db_cursor() ;
	187	-Flags => DB_CREATE ;
	188
	189	ok my $cursor = ((tied @array)->db_cursor()) ;
189	190	# check the database is empty
190	191	my $count = 0 ;
191	192	my ($k, $v) = (0,"") ;
192	193	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
193	194	++ $count ;
194	195	}
195		ok 48, $cursor->status() == DB_NOTFOUND ;
196		ok 49, $count == 0 ;
197
198		ok 50, @array == 0 ;
	196	ok $cursor->status() == DB_NOTFOUND ;
	197	ok $count == 0 ;
	198
	199	ok @array == 0 ;
199	200
200	201	# Add a k/v pair
201	202	my $value ;
202	203	$array[1] = "some value";
203		ok 51, (tied @array)->status() == 0 ;
204		ok 52, $array[1] eq "some value";
205		ok 53, defined $array[1];
206		ok 54, (tied @array)->status() == 0 ;
207		ok 55, !defined $array[3];
208		ok 56, (tied @array)->status() == DB_NOTFOUND ;
209
210		ok 57, (tied @array)->db_del(1) == 0 ;
211		ok 58, (tied @array)->status() == 0 ;
212		ok 59, ! defined $array[1];
213		ok 60, (tied @array)->status() == DB_NOTFOUND ;
	204	ok ((tied @array)->status() == 0) ;
	205	ok $array[1] eq "some value";
	206	ok defined $array[1];
	207	ok ((tied @array)->status() == 0) ;
	208	ok !defined $array[3];
	209	ok ((tied @array)->status() == DB_NOTFOUND) ;
	210
	211	ok ((tied @array)->db_del(1) == 0) ;
	212	ok ((tied @array)->status() == 0) ;
	213	ok ! defined $array[1];
	214	ok ((tied @array)->status() == DB_NOTFOUND) ;
214	215
215	216	$array[1] = 2 ;
216	217	$array[10] = 20 ;

225	226	$values += $v ;
226	227	++ $count ;
227	228	}
228		ok 61, $count == 3 ;
229		ok 62, $keys == 1011 ;
230		ok 63, $values == 2022 ;
	229	ok $count == 3 ;
	230	ok $keys == 1011 ;
	231	ok $values == 2022 ;
231	232
232	233	# unshift
233	234	$FA ? unshift @array, "red", "green", "blue"
234	235	: $db->unshift("red", "green", "blue" ) ;
235		ok 64, $array[1] eq "red" ;
236		ok 65, $cursor->c_get($k, $v, DB_FIRST) == 0 ;
237		ok 66, $k == 1 ;
238		ok 67, $v eq "red" ;
239		ok 68, $array[2] eq "green" ;
240		ok 69, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
241		ok 70, $k == 2 ;
242		ok 71, $v eq "green" ;
243		ok 72, $array[3] eq "blue" ;
244		ok 73, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
245		ok 74, $k == 3 ;
246		ok 75, $v eq "blue" ;
247		ok 76, $array[4] == 2 ;
248		ok 77, $cursor->c_get($k, $v, DB_NEXT) == 0 ;
249		ok 78, $k == 4 ;
250		ok 79, $v == 2 ;
	236	ok $array[1] eq "red" ;
	237	ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
	238	ok $k == 1 ;
	239	ok $v eq "red" ;
	240	ok $array[2] eq "green" ;
	241	ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
	242	ok $k == 2 ;
	243	ok $v eq "green" ;
	244	ok $array[3] eq "blue" ;
	245	ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
	246	ok $k == 3 ;
	247	ok $v eq "blue" ;
	248	ok $array[4] == 2 ;
	249	ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
	250	ok $k == 4 ;
	251	ok $v == 2 ;
251	252
252	253	# shift
253		ok 80, ($FA ? shift @array : $db->shift()) eq "red" ;
254		ok 81, ($FA ? shift @array : $db->shift()) eq "green" ;
255		ok 82, ($FA ? shift @array : $db->shift()) eq "blue" ;
256		ok 83, ($FA ? shift @array : $db->shift()) == 2 ;
	254	ok (($FA ? shift @array : $db->shift()) eq "red") ;
	255	ok (($FA ? shift @array : $db->shift()) eq "green") ;
	256	ok (($FA ? shift @array : $db->shift()) eq "blue") ;
	257	ok (($FA ? shift @array : $db->shift()) == 2) ;
257	258
258	259	# push
259	260	$FA ? push @array, "the", "end"
260	261	: $db->push("the", "end") ;
261		ok 84, $cursor->c_get($k, $v, DB_LAST) == 0 ;
262		ok 85, $k == 1001 ;
263		ok 86, $v eq "end" ;
264		ok 87, $cursor->c_get($k, $v, DB_PREV) == 0 ;
265		ok 88, $k == 1000 ;
266		ok 89, $v eq "the" ;
267		ok 90, $cursor->c_get($k, $v, DB_PREV) == 0 ;
268		ok 91, $k == 999 ;
269		ok 92, $v == 2000 ;
	262	ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
	263	ok $k == 1001 ;
	264	ok $v eq "end" ;
	265	ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
	266	ok $k == 1000 ;
	267	ok $v eq "the" ;
	268	ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
	269	ok $k == 999 ;
	270	ok $v == 2000 ;
270	271
271	272	# pop
272		ok 93, ( $FA ? pop @array : $db->pop ) eq "end" ;
273		ok 94, ( $FA ? pop @array : $db->pop ) eq "the" ;
274		ok 95, ( $FA ? pop @array : $db->pop ) == 2000 ;
	273	ok (( $FA ? pop @array : $db->pop ) eq "end") ;
	274	ok (( $FA ? pop @array : $db->pop ) eq "the") ;
	275	ok (( $FA ? pop @array : $db->pop ) == 2000) ;
275	276
276	277	# now clear the array
277	278	$FA ? @array = ()
278	279	: $db->clear() ;
279		ok 96, $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
	280	ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
280	281
281	282	undef $cursor ;
282	283	undef $db ;

289	290	my @array ;
290	291	my $fd ;
291	292	my $value ;
292		ok 97, my $db = tie @array, 'BerkeleyDB::Recno' ;
293
294		ok 98, $db->db_put(1, "some value") == 0 ;
295		ok 99, $db->db_get(1, $value) == 0 ;
296		ok 100, $value eq "some value" ;
	293	ok my $db = tie @array, 'BerkeleyDB::Recno' ;
	294
	295	ok $db->db_put(1, "some value") == 0 ;
	296	ok $db->db_get(1, $value) == 0 ;
	297	ok $value eq "some value" ;
297	298
298	299	}
299	300

303	304
304	305	my $lex = new LexFile $Dfile ;
305	306	my $value ;
306		ok 101, my $db = new BerkeleyDB::Recno, -Filename => $Dfile,
307		-Flags => DB_CREATE ;
	307	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	308	-Flags => DB_CREATE ;
308	309
309	310	# create some data
310	311	my @data = (

319	320	for ($i = 1 ; $i < @data ; ++$i) {
320	321	$ret += $db->db_put($i, $data[$i]) ;
321	322	}
322		ok 102, $ret == 0 ;
	323	ok $ret == 0 ;
323	324
324	325
325	326	# do a partial get
326	327	my ($pon, $off, $len) = $db->partial_set(0,2) ;
327		ok 103, ! $pon && $off == 0 && $len == 0 ;
328		ok 104, $db->db_get(1, $value) == 0 && $value eq "bo" ;
329		ok 105, $db->db_get(2, $value) == 0 && $value eq "ho" ;
330		ok 106, $db->db_get(3, $value) == 0 && $value eq "se" ;
	328	ok ! $pon && $off == 0 && $len == 0 ;
	329	ok $db->db_get(1, $value) == 0 && $value eq "bo" ;
	330	ok $db->db_get(2, $value) == 0 && $value eq "ho" ;
	331	ok $db->db_get(3, $value) == 0 && $value eq "se" ;
331	332
332	333	# do a partial get, off end of data
333	334	($pon, $off, $len) = $db->partial_set(3,2) ;
334		ok 107, $pon ;
335		ok 108, $off == 0 ;
336		ok 109, $len == 2 ;
337		ok 110, $db->db_get(1, $value) == 0 && $value eq "t" ;
338		ok 111, $db->db_get(2, $value) == 0 && $value eq "se" ;
339		ok 112, $db->db_get(3, $value) == 0 && $value eq "" ;
	335	ok $pon ;
	336	ok $off == 0 ;
	337	ok $len == 2 ;
	338	ok $db->db_get(1, $value) == 0 && $value eq "t" ;
	339	ok $db->db_get(2, $value) == 0 && $value eq "se" ;
	340	ok $db->db_get(3, $value) == 0 && $value eq "" ;
340	341
341	342	# switch of partial mode
342	343	($pon, $off, $len) = $db->partial_clear() ;
343		ok 113, $pon ;
344		ok 114, $off == 3 ;
345		ok 115, $len == 2 ;
346		ok 116, $db->db_get(1, $value) == 0 && $value eq "boat" ;
347		ok 117, $db->db_get(2, $value) == 0 && $value eq "house" ;
348		ok 118, $db->db_get(3, $value) == 0 && $value eq "sea" ;
	344	ok $pon ;
	345	ok $off == 3 ;
	346	ok $len == 2 ;
	347	ok $db->db_get(1, $value) == 0 && $value eq "boat" ;
	348	ok $db->db_get(2, $value) == 0 && $value eq "house" ;
	349	ok $db->db_get(3, $value) == 0 && $value eq "sea" ;
349	350
350	351	# now partial put
351	352	$db->partial_set(0,2) ;
352		ok 119, $db->db_put(1, "") == 0 ;
353		ok 120, $db->db_put(2, "AB") == 0 ;
354		ok 121, $db->db_put(3, "XYZ") == 0 ;
355		ok 122, $db->db_put(4, "KLM") == 0 ;
	353	ok $db->db_put(1, "") == 0 ;
	354	ok $db->db_put(2, "AB") == 0 ;
	355	ok $db->db_put(3, "XYZ") == 0 ;
	356	ok $db->db_put(4, "KLM") == 0 ;
356	357
357	358	($pon, $off, $len) = $db->partial_clear() ;
358		ok 123, $pon ;
359		ok 124, $off == 0 ;
360		ok 125, $len == 2 ;
361		ok 126, $db->db_get(1, $value) == 0 && $value eq "at" ;
362		ok 127, $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
363		ok 128, $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
364		ok 129, $db->db_get(4, $value) == 0 && $value eq "KLM" ;
	359	ok $pon ;
	360	ok $off == 0 ;
	361	ok $len == 2 ;
	362	ok $db->db_get(1, $value) == 0 && $value eq "at" ;
	363	ok $db->db_get(2, $value) == 0 && $value eq "ABuse" ;
	364	ok $db->db_get(3, $value) == 0 && $value eq "XYZa" ;
	365	ok $db->db_get(4, $value) == 0 && $value eq "KLM" ;
365	366
366	367	# now partial put
367	368	($pon, $off, $len) = $db->partial_set(3,2) ;
368		ok 130, ! $pon ;
369		ok 131, $off == 0 ;
370		ok 132, $len == 0 ;
371		ok 133, $db->db_put(1, "PPP") == 0 ;
372		ok 134, $db->db_put(2, "Q") == 0 ;
373		ok 135, $db->db_put(3, "XYZ") == 0 ;
374		ok 136, $db->db_put(4, "TU") == 0 ;
	369	ok ! $pon ;
	370	ok $off == 0 ;
	371	ok $len == 0 ;
	372	ok $db->db_put(1, "PPP") == 0 ;
	373	ok $db->db_put(2, "Q") == 0 ;
	374	ok $db->db_put(3, "XYZ") == 0 ;
	375	ok $db->db_put(4, "TU") == 0 ;
375	376
376	377	$db->partial_clear() ;
377		ok 137, $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
378		ok 138, $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
379		ok 139, $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
380		ok 140, $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
	378	ok $db->db_get(1, $value) == 0 && $value eq "at\0PPP" ;
	379	ok $db->db_get(2, $value) == 0 && $value eq "ABuQ" ;
	380	ok $db->db_get(3, $value) == 0 && $value eq "XYZXYZ" ;
	381	ok $db->db_get(4, $value) == 0 && $value eq "KLMTU" ;
381	382	}
382	383
383	384	{

387	388	my $lex = new LexFile $Dfile ;
388	389	my @array ;
389	390	my $value ;
390		ok 141, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	391	ok my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
391	392	-Flags => DB_CREATE ;
392	393
393	394	# create some data

406	407
407	408	# do a partial get
408	409	$db->partial_set(0,2) ;
409		ok 142, $array[1] eq "bo" ;
410		ok 143, $array[2] eq "ho" ;
411		ok 144, $array[3] eq "se" ;
	410	ok $array[1] eq "bo" ;
	411	ok $array[2] eq "ho" ;
	412	ok $array[3] eq "se" ;
412	413
413	414	# do a partial get, off end of data
414	415	$db->partial_set(3,2) ;
415		ok 145, $array[1] eq "t" ;
416		ok 146, $array[2] eq "se" ;
417		ok 147, $array[3] eq "" ;
	416	ok $array[1] eq "t" ;
	417	ok $array[2] eq "se" ;
	418	ok $array[3] eq "" ;
418	419
419	420	# switch of partial mode
420	421	$db->partial_clear() ;
421		ok 148, $array[1] eq "boat" ;
422		ok 149, $array[2] eq "house" ;
423		ok 150, $array[3] eq "sea" ;
	422	ok $array[1] eq "boat" ;
	423	ok $array[2] eq "house" ;
	424	ok $array[3] eq "sea" ;
424	425
425	426	# now partial put
426	427	$db->partial_set(0,2) ;
427		ok 151, $array[1] = "" ;
428		ok 152, $array[2] = "AB" ;
429		ok 153, $array[3] = "XYZ" ;
430		ok 154, $array[4] = "KLM" ;
	428	ok $array[1] = "" ;
	429	ok $array[2] = "AB" ;
	430	ok $array[3] = "XYZ" ;
	431	ok $array[4] = "KLM" ;
431	432
432	433	$db->partial_clear() ;
433		ok 155, $array[1] eq "at" ;
434		ok 156, $array[2] eq "ABuse" ;
435		ok 157, $array[3] eq "XYZa" ;
436		ok 158, $array[4] eq "KLM" ;
	434	ok $array[1] eq "at" ;
	435	ok $array[2] eq "ABuse" ;
	436	ok $array[3] eq "XYZa" ;
	437	ok $array[4] eq "KLM" ;
437	438
438	439	# now partial put
439	440	$db->partial_set(3,2) ;
440		ok 159, $array[1] = "PPP" ;
441		ok 160, $array[2] = "Q" ;
442		ok 161, $array[3] = "XYZ" ;
443		ok 162, $array[4] = "TU" ;
	441	ok $array[1] = "PPP" ;
	442	ok $array[2] = "Q" ;
	443	ok $array[3] = "XYZ" ;
	444	ok $array[4] = "TU" ;
444	445
445	446	$db->partial_clear() ;
446		ok 163, $array[1] eq "at\0PPP" ;
447		ok 164, $array[2] eq "ABuQ" ;
448		ok 165, $array[3] eq "XYZXYZ" ;
449		ok 166, $array[4] eq "KLMTU" ;
	447	ok $array[1] eq "at\0PPP" ;
	448	ok $array[2] eq "ABuQ" ;
	449	ok $array[3] eq "XYZXYZ" ;
	450	ok $array[4] eq "KLMTU" ;
450	451	}
451	452
452	453	{

457	458	my $value ;
458	459
459	460	my $home = "./fred" ;
460		ok 167, my $lexD = new LexDir($home);
461		ok 168, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	461	ok my $lexD = new LexDir($home);
	462	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
462	463	-Flags => DB_CREATE\|DB_INIT_TXN\|
463	464	DB_INIT_MPOOL\|DB_INIT_LOCK ;
464		ok 169, my $txn = $env->txn_begin() ;
465		ok 170, my $db1 = tie @array, 'BerkeleyDB::Recno',
	465	ok my $txn = $env->txn_begin() ;
	466	ok my $db1 = tie @array, 'BerkeleyDB::Recno',
466	467	-Filename => $Dfile,
467	468	-ArrayBase => 0,
468	469	-Flags => DB_CREATE ,

470	471	-Txn => $txn ;
471	472
472	473
473		ok 171, $txn->txn_commit() == 0 ;
474		ok 172, $txn = $env->txn_begin() ;
	474	ok $txn->txn_commit() == 0 ;
	475	ok $txn = $env->txn_begin() ;
475	476	$db1->Txn($txn);
476	477
477	478	# create some data

486	487	for ($i = 0 ; $i < @data ; ++$i) {
487	488	$ret += $db1->db_put($i, $data[$i]) ;
488	489	}
489		ok 173, $ret == 0 ;
	490	ok $ret == 0 ;
490	491
491	492	# should be able to see all the records
492	493
493		ok 174, my $cursor = $db1->db_cursor() ;
	494	ok my $cursor = $db1->db_cursor() ;
494	495	my ($k, $v) = (0, "") ;
495	496	my $count = 0 ;
496	497	# sequence forwards
497	498	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
498	499	++ $count ;
499	500	}
500		ok 175, $count == 3 ;
	501	ok $count == 3 ;
501	502	undef $cursor ;
502	503
503	504	# now abort the transaction
504		ok 176, $txn->txn_abort() == 0 ;
	505	ok $txn->txn_abort() == 0 ;
505	506
506	507	# there shouldn't be any records in the database
507	508	$count = 0 ;
508	509	# sequence forwards
509		ok 177, $cursor = $db1->db_cursor() ;
	510	ok $cursor = $db1->db_cursor() ;
510	511	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
511	512	++ $count ;
512	513	}
513		ok 178, $count == 0 ;
	514	ok $count == 0 ;
514	515
515	516	undef $txn ;
516	517	undef $cursor ;

527	528	my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
528	529	my @array ;
529	530	my ($k, $v) ;
530		ok 179, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	531	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
531	532	-Flags => DB_CREATE,
532	533	-Pagesize => 4 * 1024,
533	534	;
534	535
535	536	my $ref = $db->db_stat() ;
536		ok 180, $ref->{$recs} == 0;
537		ok 181, $ref->{'bt_pagesize'} == 4 * 1024;
	537	ok $ref->{$recs} == 0;
	538	ok $ref->{'bt_pagesize'} == 4 * 1024;
538	539
539	540	# create some data
540	541	my @data = (

548	549	for ($i = $db->ArrayOffset ; @data ; ++$i) {
549	550	$ret += $db->db_put($i, shift @data) ;
550	551	}
551		ok 182, $ret == 0 ;
	552	ok $ret == 0 ;
552	553
553	554	$ref = $db->db_stat() ;
554		ok 183, $ref->{$recs} == 3;
	555	ok $ref->{$recs} == 3;
555	556	}
556	557
557	558	{

601	602	close FILE ;
602	603
603	604	BEGIN { push @INC, '.'; }
	605	use Test::More;
604	606	eval 'use SubDB ; ';
605		main::ok 184, $@ eq "" ;
	607	ok $@ eq "" ;
606	608	my @h ;
607	609	my $X ;
608	610	eval '

611	613	-Mode => 0640 );
612	614	' ;
613	615
614		main::ok 185, $@ eq "" ;
	616	ok $@ eq "" ;
615	617
616	618	my $ret = eval '$h[1] = 3 ; return $h[1] ' ;
617		main::ok 186, $@ eq "" ;
618		main::ok 187, $ret == 7 ;
	619	ok $@ eq "" ;
	620	ok $ret == 7 ;
619	621
620	622	my $value = 0;
621	623	$ret = eval '$X->db_put(1, 4) ; $X->db_get(1, $value) ; return $value' ;
622		main::ok 188, $@ eq "" ;
623		main::ok 189, $ret == 10 ;
	624	ok $@ eq "" ;
	625	ok $ret == 10 ;
624	626
625	627	$ret = eval ' DB_NEXT eq main::DB_NEXT ' ;
626		main::ok 190, $@ eq "" ;
627		main::ok 191, $ret == 1 ;
	628	ok $@ eq "" ;
	629	ok $ret == 1 ;
628	630
629	631	$ret = eval '$X->A_new_method(1) ' ;
630		main::ok 192, $@ eq "" ;
631		main::ok 193, $ret eq "[[10]]" ;
	632	ok $@ eq "" ;
	633	ok $ret eq "[[10]]" ;
632	634
633	635	undef $X;
634	636	untie @h;

643	645	touch $Dfile2 ;
644	646	my @array ;
645	647	my $value ;
646		ok 194, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	648	ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
647	649	-ArrayBase => 0,
648	650	-Flags => DB_CREATE ,
649	651	-Source => $Dfile2 ;

653	655	untie @array ;
654	656
655	657	my $x = docat($Dfile2) ;
656		ok 195, $x eq "abc\ndef\n\nghi\n" ;
	658	ok $x eq "abc\ndef\n\nghi\n" ;
657	659	}
658	660
659	661	{

663	665	touch $Dfile2 ;
664	666	my @array ;
665	667	my $value ;
666		ok 196, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	668	ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
667	669	-ArrayBase => 0,
668	670	-Flags => DB_CREATE ,
669	671	-Source => $Dfile2 ,

674	676	untie @array ;
675	677
676	678	my $x = docat($Dfile2) ;
677		ok 197, $x eq "abc-def--ghi-";
	679	ok $x eq "abc-def--ghi-";
678	680	}
679	681
680	682	{

684	686	touch $Dfile2 ;
685	687	my @array ;
686	688	my $value ;
687		ok 198, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	689	ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
688	690	-ArrayBase => 0,
689	691	-Flags => DB_CREATE ,
690	692	-Len => 5,

695	697	untie @array ;
696	698
697	699	my $x = docat($Dfile2) ;
698		ok 199, $x eq "abc def ghi " ;
	700	ok $x eq "abc def ghi " ;
699	701	}
700	702
701	703	{

705	707	touch $Dfile2 ;
706	708	my @array ;
707	709	my $value ;
708		ok 200, tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	710	ok tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
709	711	-ArrayBase => 0,
710	712	-Flags => DB_CREATE ,
711	713	-Len => 5,

717	719	untie @array ;
718	720
719	721	my $x = docat($Dfile2) ;
720		ok 201, $x eq "abc--def-------ghi--" ;
	722	ok $x eq "abc--def-------ghi--" ;
721	723	}
722	724
723	725	{

726	728	my $lex = new LexFile $Dfile;
727	729	my @array ;
728	730	my $value ;
729		ok 202, my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
	731	ok my $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
730	732	-Property => DB_RENUMBER,
731	733	-ArrayBase => 0,
732	734	-Flags => DB_CREATE ;

735	737	$array[1] = "def" ;
736	738	$array[3] = "ghi" ;
737	739
738		ok 203, my ($length, $joined) = joiner($db, "\|") ;
739		ok 204, $length == 3 ;
740		ok 205, $joined eq "abc\|def\|ghi";
741
742		ok 206, $db->db_del(1) == 0 ;
743		ok 207, ($length, $joined) = joiner($db, "\|") ;
744		ok 208, $length == 2 ;
745		ok 209, $joined eq "abc\|ghi";
	740	ok my ($length, $joined) = joiner($db, "\|") ;
	741	ok $length == 3 ;
	742	ok $joined eq "abc\|def\|ghi";
	743
	744	ok $db->db_del(1) == 0 ;
	745	($length, $joined) = joiner($db, "\|") ;
	746	ok $length == 2 ;
	747	ok $joined eq "abc\|ghi";
746	748
747	749	undef $db ;
748	750	untie @array ;

755	757	my $lex = new LexFile $Dfile;
756	758	my @array ;
757	759	my $value ;
758		ok 210, my $db = tie @array, 'BerkeleyDB::Recno',
	760	ok my $db = tie @array, 'BerkeleyDB::Recno',
759	761	-Filename => $Dfile,
760	762	-Flags => DB_CREATE ;
761	763

764	766	$array[3] = "ghi" ;
765	767
766	768	my $k = 0 ;
767		ok 211, $db->db_put($k, "fred", DB_APPEND) == 0 ;
768		ok 212, $k == 4 ;
	769	ok $db->db_put($k, "fred", DB_APPEND) == 0 ;
	770	ok $k == 4 ;
769	771
770	772	undef $db ;
771	773	untie @array ;

778	780	touch $Dfile2 ;
779	781	my @array ;
780	782	my $value ;
781		ok 213, tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 ,
	783	ok tie @array, 'BerkeleyDB::Recno', -Source => $Dfile2 ,
782	784	-ArrayBase => 0,
783	785	-Property => DB_RENUMBER,
784	786	-Flags => DB_CREATE ;

788	790	untie @array ;
789	791
790	792	my $x = docat($Dfile2) ;
791		ok 214, $x eq "abc\ndef\n\nghi\n" ;
	793	ok $x eq "abc\ndef\n\nghi\n" ;
792	794	}
793	795
794	796	{

798	800	touch $Dfile2 ;
799	801	my @array ;
800	802	my $value ;
801		ok 215, tie @array, 'BerkeleyDB::Recno',
	803	ok tie @array, 'BerkeleyDB::Recno',
802	804	-ArrayBase => 0,
803	805	-Flags => DB_CREATE ,
804	806	-Source => $Dfile2 ,

810	812	untie @array ;
811	813
812	814	my $x = docat($Dfile2) ;
813		ok 216, $x eq "abc-def--ghi-";
	815	ok $x eq "abc-def--ghi-";
814	816	}
815	817
816	818	{

820	822	touch $Dfile2 ;
821	823	my @array ;
822	824	my $value ;
823		ok 217, tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0,
	825	ok tie @array, 'BerkeleyDB::Recno', -ArrayBase => 0,
824	826	-Flags => DB_CREATE ,
825	827	-Property => DB_RENUMBER,
826	828	-Len => 5,

831	833	untie @array ;
832	834
833	835	my $x = docat($Dfile2) ;
834		ok 218, $x eq "abc def ghi " ;
	836	ok $x eq "abc def ghi " ;
835	837	}
836	838
837	839	{

841	843	touch $Dfile2 ;
842	844	my @array ;
843	845	my $value ;
844		ok 219, tie @array, 'BerkeleyDB::Recno',
	846	ok tie @array, 'BerkeleyDB::Recno',
845	847	-ArrayBase => 0,
846	848	-Flags => DB_CREATE ,
847	849	-Property => DB_RENUMBER,

854	856	untie @array ;
855	857
856	858	my $x = docat($Dfile2) ;
857		ok 220, $x eq "abc--def-------ghi--" ;
	859	ok $x eq "abc--def-------ghi--" ;
858	860	}
859	861
860	862	{

862	864	my $lex = new LexFile $Dfile ;
863	865	my @array ;
864	866	my $db ;
865		ok 221, $db = tie @array, 'BerkeleyDB::Recno',
	867	ok $db = tie @array, 'BerkeleyDB::Recno',
866	868	-ArrayBase => 0,
867	869	-Flags => DB_CREATE ,
868	870	-Property => DB_RENUMBER,

870	872	$FA ? push @array, "first"
871	873	: $db->push("first") ;
872	874
873		ok 222, $array[0] eq "first" ;
874		ok 223, $FA ? pop @array : $db->pop() eq "first" ;
	875	ok $array[0] eq "first" ;
	876	ok $FA ? pop @array : $db->pop() eq "first" ;
875	877
876	878	undef $db;
877	879	untie @array ;

883	885	my $lex = new LexFile $Dfile ;
884	886	my @array ;
885	887	my $db ;
886		ok 224, $db = tie @array, 'BerkeleyDB::Recno',
	888	ok $db = tie @array, 'BerkeleyDB::Recno',
887	889	-ArrayBase => 0,
888	890	-Flags => DB_CREATE ,
889	891	-Property => DB_RENUMBER,

891	893	$FA ? unshift @array, "first"
892	894	: $db->unshift("first") ;
893	895
894		ok 225, $array[0] eq "first" ;
895		ok 226, ($FA ? shift @array : $db->shift()) eq "first" ;
	896	ok $array[0] eq "first" ;
	897	ok (($FA ? shift @array : $db->shift()) eq "first") ;
896	898
897	899	undef $db;
898	900	untie @array ;

+55

-0

t/sequence.t less more

	0
	1	use strict ;
	2
	3	use lib 't' ;
	4	use Test::More;
	5	use BerkeleyDB;
	6	use util;
	7
	8	plan(skip_all => "Sequence needs Berkeley DB 4.3.x or better\n" )
	9	if $BerkeleyDB::db_version < 4.3;
	10
	11	plan tests => 13;
	12
	13	{
	14	my $home = "./fred7" ;
	15	ok my $lexD = new LexDir($home) ;
	16	my $Dfile = "$home/f" ;
	17	my $lex = new LexFile $Dfile;
	18
	19	umask(0) ;
	20
	21	my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	22	-Flags => DB_CREATE\|DB_INIT_MPOOL;
	23	isa_ok($env, "BerkeleyDB::Env");
	24
	25	my $db = BerkeleyDB::Btree->new(
	26	Env => $env,
	27	-Filename => $Dfile,
	28	-Flags => DB_CREATE
	29	);
	30
	31	my $seq = $db->db_create_sequence();
	32	isa_ok($seq, "BerkeleyDB::Sequence");
	33
	34	is int $seq->set_cachesize(42), 0, "set_cachesize";
	35
	36	my $key = "test sequence";
	37	is int $seq->open($key), DB_NOTFOUND, "opened with no CREATE";
	38	is int $seq->open($key, DB_CREATE), 0, "opened";
	39
	40	my $gotcs;
	41	is int $seq->get_cachesize($gotcs), 0;
	42	is $gotcs, 42;
	43
	44	# First sequence should be 0
	45	my $val;
	46	is int $seq->get($val), 0, "get";
	47	is length($val), 8, "64 bts == 8 bytes";
	48
	49	my $gotkey ='';
	50	is int $seq->get_key($gotkey), 0, "get_key";
	51	is $gotkey, $key;
	52
	53	is int $seq->close(), 0, "close";
	54	}

+47

-45

t/strict.t less more

5	5	use BerkeleyDB;
6	6	use util ;
7	7
8		print "1..44\n";
	8	use Test::More ;
	9
	10	plan tests => 44;
9	11
10	12	my $Dfile = "dbhash.tmp";
11	13	my $home = "./fred" ;

18	20	my %hash ;
19	21	my $status ;
20	22
21		ok 1, my $lexD = new LexDir($home);
22		ok 2, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	23	ok my $lexD = new LexDir($home);
	24	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
23	25	-Flags => DB_CREATE\|DB_INIT_TXN\|
24	26	DB_INIT_MPOOL\|DB_INIT_LOCK ;
25	27
26		ok 3, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	28	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
27	29	-Flags => DB_CREATE ,
28	30	-Env => $env;
29	31
30		ok 4, $db1->db_close() == 0 ;
	32	ok $db1->db_close() == 0 ;
31	33
32	34	eval { $status = $env->db_appexit() ; } ;
33		ok 5, $status == 0 ;
34		ok 6, $@ eq "" ;
	35	ok $status == 0 ;
	36	ok $@ eq "" ;
35	37	#print "[$@]\n" ;
36	38
37	39	}

41	43	my $lex = new LexFile $Dfile ;
42	44	my %hash ;
43	45
44		ok 7, my $lexD = new LexDir($home);
45		ok 8, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	46	ok my $lexD = new LexDir($home);
	47	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
46	48	-Flags => DB_CREATE\|DB_INIT_TXN\|
47	49	DB_INIT_MPOOL\|DB_INIT_LOCK ;
48	50
49		ok 9, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	51	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
50	52	-Flags => DB_CREATE ,
51	53	-Env => $env;
52	54
53	55	eval { $env->db_appexit() ; } ;
54		ok 10, $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ;
	56	ok $@ =~ /BerkeleyDB Aborting: attempted to close an environment with 1 open database/ ;
55	57	#print "[$@]\n" ;
56	58
57	59	undef $db1 ;

65	67	my %hash ;
66	68	my $status ;
67	69
68		ok 11, my $lexD = new LexDir($home);
69		ok 12, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	70	ok my $lexD = new LexDir($home);
	71	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
70	72	-Flags => DB_CREATE\|DB_INIT_TXN\|
71	73	DB_INIT_MPOOL\|DB_INIT_LOCK ;
72	74
73		ok 13, my $txn = $env->txn_begin() ;
74		ok 14, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	75	ok my $txn = $env->txn_begin() ;
	76	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
75	77	-Flags => DB_CREATE ,
76	78	-Env => $env,
77	79	-Txn => $txn ;
78	80
79		ok 15, $txn->txn_commit() == 0 ;
	81	ok $txn->txn_commit() == 0 ;
80	82	eval { $status = $db->db_close() ; } ;
81		ok 16, $status == 0 ;
82		ok 17, $@ eq "" ;
	83	ok $status == 0 ;
	84	ok $@ eq "" ;
83	85	#print "[$@]\n" ;
84	86	eval { $status = $env->db_appexit() ; } ;
85		ok 18, $status == 0 ;
86		ok 19, $@ eq "" ;
	87	ok $status == 0 ;
	88	ok $@ eq "" ;
87	89	#print "[$@]\n" ;
88	90	}
89	91

92	94	my $lex = new LexFile $Dfile ;
93	95	my %hash ;
94	96
95		ok 20, my $lexD = new LexDir($home);
96		ok 21, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	97	ok my $lexD = new LexDir($home);
	98	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
97	99	-Flags => DB_CREATE\|DB_INIT_TXN\|
98	100	DB_INIT_MPOOL\|DB_INIT_LOCK ;
99	101
100		ok 22, my $txn = $env->txn_begin() ;
101		ok 23, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	102	ok my $txn = $env->txn_begin() ;
	103	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
102	104	-Flags => DB_CREATE ,
103	105	-Env => $env,
104	106	-Txn => $txn ;
105	107
106	108	eval { $db->db_close() ; } ;
107		ok 24, $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ;
	109	ok $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ;
108	110	#print "[$@]\n" ;
109	111	$txn->txn_abort();
110	112	$db->db_close();

115	117	my $lex = new LexFile $Dfile ;
116	118	my %hash ;
117	119	my $status ;
118		ok 25, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	120	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
119	121	-Flags => DB_CREATE ;
120		ok 26, my $cursor = $db->db_cursor() ;
121		ok 27, $cursor->c_close() == 0 ;
	122	ok my $cursor = $db->db_cursor() ;
	123	ok $cursor->c_close() == 0 ;
122	124	eval { $status = $db->db_close() ; } ;
123		ok 28, $status == 0 ;
124		ok 29, $@ eq "" ;
	125	ok $status == 0 ;
	126	ok $@ eq "" ;
125	127	#print "[$@]\n" ;
126	128	}
127	129

129	131	# closing a database with an open cursor
130	132	my $lex = new LexFile $Dfile ;
131	133	my %hash ;
132		ok 30, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	134	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
133	135	-Flags => DB_CREATE ;
134		ok 31, my $cursor = $db->db_cursor() ;
	136	ok my $cursor = $db->db_cursor() ;
135	137	eval { $db->db_close() ; } ;
136		ok 32, $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/;
	138	ok $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/;
137	139	#print "[$@]\n" ;
138	140	}
139	141

144	146	my $status ;
145	147	my $home = 'fred1';
146	148
147		ok 33, my $lexD = new LexDir($home);
148		ok 34, my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
	149	ok my $lexD = new LexDir($home);
	150	ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
149	151	-Flags => DB_CREATE\|DB_INIT_TXN\|
150	152	DB_INIT_MPOOL\|DB_INIT_LOCK ;
151		ok 35, my $txn = $env->txn_begin() ;
152		ok 36, my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	153	ok my $txn = $env->txn_begin() ;
	154	ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
153	155	-Flags => DB_CREATE ,
154	156	-Env => $env,
155	157	-Txn => $txn ;
156		ok 37, my $cursor = $db->db_cursor() ;
	158	ok my $cursor = $db->db_cursor() ;
157	159	eval { $status = $cursor->c_close() ; } ;
158		ok 38, $status == 0 ;
159		ok 39, ($status = $txn->txn_commit()) == 0 ;
160		ok 40, $@ eq "" ;
	160	ok $status == 0 ;
	161	ok $txn->txn_commit() == 0 ;
	162	ok $@ eq "" ;
161	163	eval { $status = $db->db_close() ; } ;
162		ok 41, $status == 0 ;
163		ok 42, $@ eq "" ;
	164	ok $status == 0 ;
	165	ok $@ eq "" ;
164	166	#print "[$@]\n" ;
165	167	eval { $status = $env->db_appexit() ; } ;
166		ok 43, $status == 0 ;
167		ok 44, $@ eq "" ;
	168	ok $status == 0 ;
	169	ok $@ eq "" ;
168	170	#print "[$@]\n" ;
169	171	}
170	172

-1

t/subdb.t less more

4	4	use lib 't' ;
5	5	use BerkeleyDB;
6	6	use Test::More ;
7		use util qw(1);
	7	use util ;
8	8
9	9	plan(skip_all => "this needs Berkeley DB 3.x or better\n" )
10	10	if $BerkeleyDB::db_version < 3;

+73

-71

t/txn.t less more

5	5	use BerkeleyDB;
6	6	use util ;
7	7
8		print "1..58\n";
	8	use Test::More ;
	9
	10	plan tests => 58;
9	11
10	12	my $Dfile = "dbhash.tmp";
11	13

19	21	my $value ;
20	22
21	23	my $home = "./fred" ;
22		ok 1, my $lexD = new LexDir($home);
23		ok 2, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	24	ok my $lexD = new LexDir($home);
	25	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
24	26	-Flags => DB_CREATE\| DB_INIT_MPOOL;
25	27	eval { $env->txn_begin() ; } ;
26		ok 3, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
	28	ok $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
27	29
28	30	eval { my $txn_mgr = $env->TxnMgr() ; } ;
29		ok 4, $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
	31	ok $@ =~ /^BerkeleyDB Aborting: Transaction Manager not enabled at/ ;
30	32	undef $env ;
31	33
32	34	}

39	41	my $value ;
40	42
41	43	my $home = "./fred" ;
42		ok 5, my $lexD = new LexDir($home);
43		ok 6, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	44	ok my $lexD = new LexDir($home);
	45	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
44	46	-Flags => DB_CREATE\|DB_INIT_TXN\|
45	47	DB_INIT_MPOOL\|DB_INIT_LOCK ;
46		ok 7, my $txn = $env->txn_begin() ;
47		ok 8, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	48	ok my $txn = $env->txn_begin() ;
	49	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
48	50	-Flags => DB_CREATE ,
49	51	-Env => $env,
50	52	-Txn => $txn ;
51	53
52	54
53		ok 9, $txn->txn_commit() == 0 ;
54		ok 10, $txn = $env->txn_begin() ;
	55	ok $txn->txn_commit() == 0 ;
	56	ok $txn = $env->txn_begin() ;
55	57	$db1->Txn($txn);
56	58
57	59	# create some data

65	67	while (my ($k, $v) = each %data) {
66	68	$ret += $db1->db_put($k, $v) ;
67	69	}
68		ok 11, $ret == 0 ;
	70	ok $ret == 0 ;
69	71
70	72	# should be able to see all the records
71	73
72		ok 12, my $cursor = $db1->db_cursor() ;
	74	ok my $cursor = $db1->db_cursor() ;
73	75	my ($k, $v) = ("", "") ;
74	76	my $count = 0 ;
75	77	# sequence forwards
76	78	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
77	79	++ $count ;
78	80	}
79		ok 13, $count == 3 ;
	81	ok $count == 3 ;
80	82	undef $cursor ;
81	83
82	84	# now abort the transaction
83		ok 14, $txn->txn_abort() == 0 ;
	85	ok $txn->txn_abort() == 0 ;
84	86
85	87	# there shouldn't be any records in the database
86	88	$count = 0 ;
87	89	# sequence forwards
88		ok 15, $cursor = $db1->db_cursor() ;
89		while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
90		++ $count ;
91		}
92		ok 16, $count == 0 ;
	90	ok $cursor = $db1->db_cursor() ;
	91	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
	92	++ $count ;
	93	}
	94	ok $count == 0 ;
93	95
94	96	my $stat = $env->txn_stat() ;
95		ok 17, $stat->{'st_naborts'} == 1 ;
	97	ok $stat->{'st_naborts'} == 1 ;
96	98
97	99	undef $txn ;
98	100	undef $cursor ;

109	111	my $value ;
110	112
111	113	my $home = "./fred" ;
112		ok 18, my $lexD = new LexDir($home);
113		ok 19, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	114	ok my $lexD = new LexDir($home);
	115	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
114	116	-Flags => DB_CREATE\|DB_INIT_TXN\|
115	117	DB_INIT_MPOOL\|DB_INIT_LOCK ;
116		ok 20, my $txn_mgr = $env->TxnMgr() ;
117		ok 21, my $txn = $txn_mgr->txn_begin() ;
118		ok 22, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	118	ok my $txn_mgr = $env->TxnMgr() ;
	119	ok my $txn = $txn_mgr->txn_begin() ;
	120	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
119	121	-Flags => DB_CREATE ,
120	122	-Env => $env,
121	123	-Txn => $txn ;
122	124
123		ok 23, $txn->txn_commit() == 0 ;
124		ok 24, $txn = $env->txn_begin() ;
	125	ok $txn->txn_commit() == 0 ;
	126	ok $txn = $env->txn_begin() ;
125	127	$db1->Txn($txn);
126	128
127	129	# create some data

135	137	while (my ($k, $v) = each %data) {
136	138	$ret += $db1->db_put($k, $v) ;
137	139	}
138		ok 25, $ret == 0 ;
	140	ok $ret == 0 ;
139	141
140	142	# should be able to see all the records
141	143
142		ok 26, my $cursor = $db1->db_cursor() ;
	144	ok my $cursor = $db1->db_cursor() ;
143	145	my ($k, $v) = ("", "") ;
144	146	my $count = 0 ;
145	147	# sequence forwards
146	148	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
147	149	++ $count ;
148	150	}
149		ok 27, $count == 3 ;
	151	ok $count == 3 ;
150	152	undef $cursor ;
151	153
152	154	# now abort the transaction
153		ok 28, $txn->txn_abort() == 0 ;
	155	ok $txn->txn_abort() == 0 ;
154	156
155	157	# there shouldn't be any records in the database
156	158	$count = 0 ;
157	159	# sequence forwards
158		ok 29, $cursor = $db1->db_cursor() ;
159		while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
160		++ $count ;
161		}
162		ok 30, $count == 0 ;
	160	ok $cursor = $db1->db_cursor() ;
	161	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
	162	++ $count ;
	163	}
	164	ok $count == 0 ;
163	165
164	166	my $stat = $txn_mgr->txn_stat() ;
165		ok 31, $stat->{'st_naborts'} == 1 ;
	167	ok $stat->{'st_naborts'} == 1 ;
166	168
167	169	undef $txn ;
168	170	undef $cursor ;

180	182	my $value ;
181	183
182	184	my $home = "./fred" ;
183		ok 32, my $lexD = new LexDir($home);
184		ok 33, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	185	ok my $lexD = new LexDir($home);
	186	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
185	187	-Flags => DB_CREATE\|DB_INIT_TXN\|
186	188	DB_INIT_MPOOL\|DB_INIT_LOCK ;
187		ok 34, my $txn = $env->txn_begin() ;
188		ok 35, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	189	ok my $txn = $env->txn_begin() ;
	190	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
189	191	-Flags => DB_CREATE ,
190	192	-Env => $env,
191	193	-Txn => $txn ;
192	194
193	195
194		ok 36, $txn->txn_commit() == 0 ;
195		ok 37, $txn = $env->txn_begin() ;
	196	ok $txn->txn_commit() == 0 ;
	197	ok $txn = $env->txn_begin() ;
196	198	$db1->Txn($txn);
197	199
198	200	# create some data

206	208	while (my ($k, $v) = each %data) {
207	209	$ret += $db1->db_put($k, $v) ;
208	210	}
209		ok 38, $ret == 0 ;
	211	ok $ret == 0 ;
210	212
211	213	# should be able to see all the records
212	214
213		ok 39, my $cursor = $db1->db_cursor() ;
	215	ok my $cursor = $db1->db_cursor() ;
214	216	my ($k, $v) = ("", "") ;
215	217	my $count = 0 ;
216	218	# sequence forwards
217	219	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
218	220	++ $count ;
219	221	}
220		ok 40, $count == 3 ;
	222	ok $count == 3 ;
221	223	undef $cursor ;
222	224
223	225	# now commit the transaction
224		ok 41, $txn->txn_commit() == 0 ;
	226	ok $txn->txn_commit() == 0 ;
225	227
226	228	$count = 0 ;
227	229	# sequence forwards
228		ok 42, $cursor = $db1->db_cursor() ;
229		while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
230		++ $count ;
231		}
232		ok 43, $count == 3 ;
	230	ok $cursor = $db1->db_cursor() ;
	231	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
	232	++ $count ;
	233	}
	234	ok $count == 3 ;
233	235
234	236	my $stat = $env->txn_stat() ;
235		ok 44, $stat->{'st_naborts'} == 0 ;
	237	ok $stat->{'st_naborts'} == 0 ;
236	238
237	239	undef $txn ;
238	240	undef $cursor ;

249	251	my $value ;
250	252
251	253	my $home = "./fred" ;
252		ok 45, my $lexD = new LexDir($home);
253		ok 46, my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
	254	ok my $lexD = new LexDir($home);
	255	ok my $env = new BerkeleyDB::Env -Home => $home, @StdErrFile,
254	256	-Flags => DB_CREATE\|DB_INIT_TXN\|
255	257	DB_INIT_MPOOL\|DB_INIT_LOCK ;
256		ok 47, my $txn_mgr = $env->TxnMgr() ;
257		ok 48, my $txn = $txn_mgr->txn_begin() ;
258		ok 49, my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
	258	ok my $txn_mgr = $env->TxnMgr() ;
	259	ok my $txn = $txn_mgr->txn_begin() ;
	260	ok my $db1 = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
259	261	-Flags => DB_CREATE ,
260	262	-Env => $env,
261	263	-Txn => $txn ;
262	264
263		ok 50, $txn->txn_commit() == 0 ;
264		ok 51, $txn = $env->txn_begin() ;
	265	ok $txn->txn_commit() == 0 ;
	266	ok $txn = $env->txn_begin() ;
265	267	$db1->Txn($txn);
266	268
267	269	# create some data

275	277	while (my ($k, $v) = each %data) {
276	278	$ret += $db1->db_put($k, $v) ;
277	279	}
278		ok 52, $ret == 0 ;
	280	ok $ret == 0 ;
279	281
280	282	# should be able to see all the records
281	283
282		ok 53, my $cursor = $db1->db_cursor() ;
	284	ok my $cursor = $db1->db_cursor() ;
283	285	my ($k, $v) = ("", "") ;
284	286	my $count = 0 ;
285	287	# sequence forwards
286	288	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
287	289	++ $count ;
288	290	}
289		ok 54, $count == 3 ;
	291	ok $count == 3 ;
290	292	undef $cursor ;
291	293
292	294	# now commit the transaction
293		ok 55, $txn->txn_commit() == 0 ;
	295	ok $txn->txn_commit() == 0 ;
294	296
295	297	$count = 0 ;
296	298	# sequence forwards
297		ok 56, $cursor = $db1->db_cursor() ;
298		while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
299		++ $count ;
300		}
301		ok 57, $count == 3 ;
	299	ok $cursor = $db1->db_cursor() ;
	300	while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
	301	++ $count ;
	302	}
	303	ok $count == 3 ;
302	304
303	305	my $stat = $txn_mgr->txn_stat() ;
304		ok 58, $stat->{'st_naborts'} == 0 ;
	306	ok $stat->{'st_naborts'} == 0 ;
305	307
306	308	undef $txn ;
307	309	undef $cursor ;

+43

-43

t/unknown.t less more

6	6	use lib 't' ;
7	7	use BerkeleyDB;
8	8	use util ;
9
10		print "1..41\n";
	9	use Test::More;
	10	plan tests => 41;
11	11
12	12	my $Dfile = "dbhash.tmp";
13	13	unlink $Dfile;

20	20	# Check for invalid parameters
21	21	my $db ;
22	22	eval ' $db = new BerkeleyDB::Unknown -Stupid => 3 ; ' ;
23		ok 1, $@ =~ /unknown key value$s$ Stupid/ ;
	23	ok $@ =~ /unknown key value$s$ Stupid/ ;
24	24
25	25	eval ' $db = new BerkeleyDB::Unknown -Bad => 2, -Mode => 0345, -Stupid => 3; ' ;
26		ok 2, $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
	26	ok $@ =~ /unknown key value$s$ (Bad,? \|Stupid,? ){2}/ ;
27	27
28	28	eval ' $db = new BerkeleyDB::Unknown -Env => 2 ' ;
29		ok 3, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	29	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
30	30
31	31	eval ' $db = new BerkeleyDB::Unknown -Txn => "fred" ' ;
32		ok 4, $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
	32	ok $@ =~ /^Txn not of type BerkeleyDB::Txn/ ;
33	33
34	34	my $obj = bless [], "main" ;
35	35	eval ' $db = new BerkeleyDB::Unknown -Env => $obj ' ;
36		ok 5, $@ =~ /^Env not of type BerkeleyDB::Env/ ;
	36	ok $@ =~ /^Env not of type BerkeleyDB::Env/ ;
37	37	}
38	38
39	39	# check the interface to a rubbish database
40	40	{
41	41	# first an empty file
42	42	my $lex = new LexFile $Dfile ;
43		ok 6, writeFile($Dfile, "") ;
	43	ok writeFile($Dfile, "") ;
44	44
45		ok 7, ! (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 8, ! (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 9, my $db = new BerkeleyDB::Hash -Filename => $Dfile,
	58	ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
59	59	-Flags => DB_CREATE ;
60	60
61	61	# Add a few k/v pairs
62	62	my $value ;
63	63	my $status ;
64		ok 10, $db->db_put("some key", "some value") == 0 ;
65		ok 11, $db->db_put("key", "value") == 0 ;
	64	ok $db->db_put("some key", "some value") == 0 ;
	65	ok $db->db_put("key", "value") == 0 ;
66	66
67	67	# close the database
68	68	undef $db ;
69	69
70	70	# now open it with Unknown
71		ok 12, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	71	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
72	72
73		ok 13, $db->type() == DB_HASH ;
74		ok 14, $db->db_get("some key", $value) == 0 ;
75		ok 15, $value eq "some value" ;
76		ok 16, $db->db_get("key", $value) == 0 ;
77		ok 17, $value eq "value" ;
	73	ok $db->type() == DB_HASH ;
	74	ok $db->db_get("some key", $value) == 0 ;
	75	ok $value eq "some value" ;
	76	ok $db->db_get("key", $value) == 0 ;
	77	ok $value eq "value" ;
78	78
79	79	my @array ;
80	80	eval { $db->Tie(\@array)} ;
81		ok 18, $@ =~ /^Tie needs a reference to a hash/ ;
	81	ok $@ =~ /^Tie needs a reference to a hash/ ;
82	82
83	83	my %hash ;
84	84	$db->Tie(\%hash) ;
85		ok 19, $hash{"some key"} eq "some value" ;
	85	ok $hash{"some key"} eq "some value" ;
86	86
87	87	}
88	88

92	92	my $lex = new LexFile $Dfile ;
93	93
94	94	# create a hash database
95		ok 20, my $db = new BerkeleyDB::Btree -Filename => $Dfile,
	95	ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
96	96	-Flags => DB_CREATE ;
97	97
98	98	# Add a few k/v pairs
99	99	my $value ;
100	100	my $status ;
101		ok 21, $db->db_put("some key", "some value") == 0 ;
102		ok 22, $db->db_put("key", "value") == 0 ;
	101	ok $db->db_put("some key", "some value") == 0 ;
	102	ok $db->db_put("key", "value") == 0 ;
103	103
104	104	# close the database
105	105	undef $db ;
106	106
107	107	# now open it with Unknown
108	108	# create a hash database
109		ok 23, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	109	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
110	110
111		ok 24, $db->type() == DB_BTREE ;
112		ok 25, $db->db_get("some key", $value) == 0 ;
113		ok 26, $value eq "some value" ;
114		ok 27, $db->db_get("key", $value) == 0 ;
115		ok 28, $value eq "value" ;
	111	ok $db->type() == DB_BTREE ;
	112	ok $db->db_get("some key", $value) == 0 ;
	113	ok $value eq "some value" ;
	114	ok $db->db_get("key", $value) == 0 ;
	115	ok $value eq "value" ;
116	116
117	117
118	118	my @array ;
119	119	eval { $db->Tie(\@array)} ;
120		ok 29, $@ =~ /^Tie needs a reference to a hash/ ;
	120	ok $@ =~ /^Tie needs a reference to a hash/ ;
121	121
122	122	my %hash ;
123	123	$db->Tie(\%hash) ;
124		ok 30, $hash{"some key"} eq "some value" ;
	124	ok $hash{"some key"} eq "some value" ;
125	125
126	126
127	127	}

132	132	my $lex = new LexFile $Dfile ;
133	133
134	134	# create a recno database
135		ok 31, my $db = new BerkeleyDB::Recno -Filename => $Dfile,
	135	ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
136	136	-Flags => DB_CREATE ;
137	137
138	138	# Add a few k/v pairs
139	139	my $value ;
140	140	my $status ;
141		ok 32, $db->db_put(0, "some value") == 0 ;
142		ok 33, $db->db_put(1, "value") == 0 ;
	141	ok $db->db_put(0, "some value") == 0 ;
	142	ok $db->db_put(1, "value") == 0 ;
143	143
144	144	# close the database
145	145	undef $db ;
146	146
147	147	# now open it with Unknown
148	148	# create a hash database
149		ok 34, $db = new BerkeleyDB::Unknown -Filename => $Dfile;
	149	ok $db = new BerkeleyDB::Unknown -Filename => $Dfile;
150	150
151		ok 35, $db->type() == DB_RECNO ;
152		ok 36, $db->db_get(0, $value) == 0 ;
153		ok 37, $value eq "some value" ;
154		ok 38, $db->db_get(1, $value) == 0 ;
155		ok 39, $value eq "value" ;
	151	ok $db->type() == DB_RECNO ;
	152	ok $db->db_get(0, $value) == 0 ;
	153	ok $value eq "some value" ;
	154	ok $db->db_get(1, $value) == 0 ;
	155	ok $value eq "value" ;
156	156
157	157
158	158	my %hash ;
159	159	eval { $db->Tie(\%hash)} ;
160		ok 40, $@ =~ /^Tie needs a reference to an array/ ;
	160	ok $@ =~ /^Tie needs a reference to an array/ ;
161	161
162	162	my @array ;
163	163	$db->Tie(\@array) ;
164		ok 41, $array[1] eq "value" ;
	164	ok $array[1] eq "value" ;
165	165
166	166
167	167	}

-24

t/util.pm less more

1	1
2	2	use strict;
3	3
4		use vars qw( $wantOK) ;
5		$wantOK = 1 ;
6
7		sub _ok
8		{
9		my $no = shift ;
10		my $result = shift ;
11
12		print "not " unless $result ;
13		print "ok $no\n" ;
14		return $result;
15		}
16
17		sub import
18		{
19		my $class = shift ;
20		my $no_want_ok = shift ;
21
22		$wantOK = 0 if $no_want_ok ;
23		if (! $no_want_ok)
24		{
25		*main::ok = \&_ok ;
26		}
27		}
28	4
29	5	package main ;
30	6

+29

-0

typemap less more

9	9
10	10	SVnull* T_SV_NULL
11	11	void * T_PV
	12	db_seq_t T_PV_64
12	13	u_int T_U_INT
13	14	u_int32_t T_U_INT
	15	int32_t T_U_INT
14	16	db_timeout_t T_U_INT
15	17	const char * T_PV_NULL
16	18	PV_or_NULL T_PV_NULL

30	32	BerkeleyDB::Log T_PTROBJ_AV
31	33	BerkeleyDB::Lock T_PTROBJ_AV
32	34	BerkeleyDB::Env T_PTROBJ_AV
	35	BerkeleyDB::Sequence T_PTROBJ_NULL
33	36
34	37	BerkeleyDB::Raw T_RAW
35	38	BerkeleyDB::Common::Raw T_RAW

56	59	DBTKEY_B T_dbtkeydatum_btree
57	60	DBTKEY_Br T_dbtkeydatum_btree_r
58	61	DBTKEY_Bpr T_dbtkeydatum_btree_pr
	62	DBTKEY_seq T_dbtkeydatum_seq
59	63	DBTYPE T_U_INT
60	64	DualType T_DUAL
61	65	BerkeleyDB_type * T_IV

81	85	T_U_INT
82	86	$var = SvUV($arg)
83	87
	88	T_INT
	89	$var = SvIV($arg)
	90
84	91	T_SV_REF_NULL
85	92	if ($arg == &PL_sv_undef)
86	93	$var = NULL ;

147	154	$var = NULL ;
148	155	}
149	156
	157	T_PV_64
	158	if ($arg == &PL_sv_undef)
	159	$var = 0 ;
	160	else {
	161	STRLEN len;
	162	$var = ($type)SvPV($arg,len) ;
	163	if (len == 0)
	164	$var = NULL ;
	165	}
	166
150	167	T_IO_NULL
151	168	if ($arg == &PL_sv_undef)
152	169	$var = NULL ;

200	217	$var.size = (int)len;
201	218	}
202	219	}
	220
	221	T_dbtkeydatum_seq
	222	InputKey_seq($arg, $var)
	223
203	224
204	225	T_dbtkeydatum_btree
205	226	{

327	348	T_U_INT
328	349	sv_setuv($arg, (UV)$var);
329	350
	351	T_INT
	352	sv_setiv($arg, (UV)$var);
	353
330	354	T_PV_NULL
331	355	sv_setpv((SV*)$arg, $var);
	356
	357	T_PV_64
	358	sv_setpvn((SV)$arg, (char)&$var, sizeof(db_seq_t));
332	359
333	360	T_dbtkeydatum_btree
334	361	OutputKey_B($arg, $var)

336	363	OutputKey_Br($arg, $var)
337	364	T_dbtkeydatum_btree_pr
338	365	OutputKey_Bpr($arg, $var)
	366	T_dbtkeydatum_seq
	367	OutputKey_seq($arg, $var)
339	368	T_dbtkeydatum
340	369	OutputKey($arg, $var)
341	370	T_dbtdatum