ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import BSDDB 4.7.25 (as of svn r89086)

Browse Source
This commit is contained in:
Zachary Ware
2017-09-04 13:40:25 -05:00
parent 4b29e0458f
commit 8f590873d0
4781 changed files with 2241032 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

262
tcl/docs/db.html Normal file
View File

@@ -0,0 +1,262 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 3.3-RELEASE i386) [Netscape]">
</HEAD>
<BODY>
<H2>
<A NAME="Database Commands"></A>Database Commands</H2>
The database commands provide a fairly straightforward mapping to the
DB method functions.
<P>
<B>> berkdb open</B>
<dl>
<dt><B>[-btcompare <I>proc</I>]</B><dd>
Sets the Btree comparison function to the Tcl procedure named
<I>proc</I> using the
<A HREF="../../docs/api_c/db_set_bt_compare.html">DB->set_bt_compare</A>
method.
<dt><B>[-btree|-hash|-recno|-queue|-unknown]</B><dd>
</td><td>
Select the database type:<br>
DB_BTREE, DB_HASH, DB_RECNO, DB_QUEUE or DB_UNKNOWN.
<dt><B>[-cachesize {<I>gbytes bytes ncaches</I>}]</B><dd>
Sets the size of the database cache to the size specified by
<I>gbytes</I> and <I>bytes</I>, broken up into <I>ncaches</I> number of
caches using the
<A HREF="../../docs/api_c/db_set_cachesize.html">DB->set_cachesize</A>
method.
<dt><B>[-create]</B><dd>
Selects the DB_CREATE flag to create underlying files.
<dt><B>[-delim <I>delim</I>]</B><dd>
Sets the delimiting byte for variable length records to <I>delim</I>
using the
<A HREF="../../docs/api_c/db_set_re_delim.html">DB->set_re_delim</A>
method.
<dt><B>[-dup]</B><dd>
Selects the DB_DUP flag to permit duplicates in the database.
<dt><B>[-dupcompare <I>proc</I>]</B><dd>
Sets the duplicate data comparison function to the Tcl procedure named
<I>proc</I> using the
<A HREF="../../docs/api_c/db_set_dup_compare.html">DB->set_dup_compare</A>
method.
<dt><B>[-dupsort]</B><dd>
Selects the DB_DUPSORT flag to support sorted duplicates.
<dt><B>[-env <I>env</I>]</B><dd>
The database environment.
<dt><B>[-errfile <I>filename</I>]</B><dd>
Specifies the error file to use for this environment to <I>filename</I>
by calling
<A HREF="../../docs/api_c/db_set_errfile.html">DB->set_errfile</A>.
If the file already exists then we will append to the end of the file.
<dt><B>[-excl]</B><dd>
Selects the DB_EXCL flag to exclusively create underlying files.
<dt><B>[-extent <I>size</I>]</B><dd>
Sets the size of a Queue database extent to the given <I>size</I> using
the
<A HREF="../../docs/api_c/db_set_q_extentsize.html">DB->set_q_extentsize</A>
method.
<dt><B>[-ffactor <I>density</I>]</B><dd>
Sets the hash table key density to the given <I>density</I> using the
<A HREF="../../docs/api_c/db_set_h_ffactor.html">DB->set_h_ffactor</A>
method.
<dt><B>[-hashproc <I>proc</I>]</B><dd>
Sets a user-defined hash function to the Tcl procedure named <I>proc</I>
using the
<A HREF="../../docs/api_c/db_set_h_hash.html">DB->set_h_hash</A> method.
<dt><B>[-len <I>len</I>]</B><dd>
Sets the length of fixed-length records to <I>len</I> using the
<A HREF="../../docs/api_c/db_set_re_len.html">DB->set_re_len</A>
method.
<dt><B>[-lorder <I>order</I>]</B><dd>
Sets the byte order for integers stored in the database meta-data to
the given <I>order</I> using the
<A HREF="../../docs/api_c/db_set_lorder.html">DB->set_lorder</A>
method.
<dt><B>[-minkey <I>minkey</I>]</B><dd>
Sets the minimum number of keys per Btree page to <I>minkey</I> using
the
<A HREF="../../docs/api_c/db_set_bt_minkey.html">DB->set_bt_minkey</A>
method.
<dt><B>[-mode <I>mode</I>]</B><dd>
Specifies the mode for created files.
<dt><B>[-nelem <I>size</I>]</B><dd>
Sets the hash table size estimate to the given <I>size</I> using the
<A HREF="../../docs/api_c/db_set_h_nelem.html">DB->set_h_nelem</A>
method.
<dt><B>[-nommap]</B><dd>
Selects the DB_NOMMAP flag to forbid mmaping of files.
<dt><B>[-pad <I>pad</I>]</B><dd>
Sets the pad character used for fixed length records to <I>pad</I> using
the
<A HREF="../../docs/db_set_re_pad.html">DB->set_re_pad</A> method.
<dt><B>[-pagesize <I>pagesize</I>]</B><dd>
Sets the size of the database page to <I>pagesize</I> using the
<A HREF="../../docs/api_c/db_set_pagesize.html">DB->set_pagesize</A>
method.
<dt><B>[-rdonly]</B><dd>
Selects the DB_RDONLY flag for opening in read-only mode.
<dt><B>[-recnum]</B><dd>
Selects the DB_RECNUM flag to support record numbers in Btrees.
<dt><B>[-renumber]</B><dd>
Selects the DB_RENUMBER flag to support mutable record numbers.
<dt><B>[-revsplitoff]</B><dd>
Selects the DB_REVSPLITOFF flag to suppress reverse splitting of pages
on deletion.
<dt><B>[-snapshot]</B><dd>
Selects the DB_SNAPSHOT flag to support database snapshots.
<dt><B>[-source <I>file</I>]</B><dd>
Sets the backing source file name to <I>file</I> using the
<A HREF="../../docs/api_c/db_set_re_source.html">DB->set_re_source</A>
method.
<dt><B>[-truncate]</B><dd>
Selects the DB_TRUNCATE flag to truncate the database.
<dt><B>[--]</B><dd>
Terminate the list of options and use remaining arguments as the file
or subdb names (thus allowing the use of filenames beginning with a dash
'-').
<dt><B>[<I>filename </I>[<I>subdbname</I>]]</B><dd>
The names of the database and sub-database.
</dl>
<HR WIDTH="100%">
<B>> berkdb upgrade [-dupsort] [-env <I>env</I>] [--] [<I>filename</I>]</B>
<P>This command will invoke the <A HREF="../../docs/api_c/db_upgrade.html">DB->upgrade</A>
function.&nbsp; If the command is given the <B>-env</B> option, then we
will accordingly upgrade the database filename within the context of that
environment. The <B>-dupsort</B> option selects the DB_DUPSORT flag for
upgrading. The use of --<B> </B>terminates the list of options, thus allowing
filenames beginning with a dash.
<P>
<HR WIDTH="100%">
<B>> berkdb verify [-env <I>env</I>] [--] [<I>filename</I>]</B>
<P>This command will invoke the <A HREF="../../docs/api_c/db_verify.html">DB->verify</A>
function.&nbsp; If the command is given the <B>-env</B> option, then we
will accordingly verify the database filename within the context of that
environment.&nbsp; The use of --<B> </B>terminates the list of options,
thus allowing filenames beginning with a dash.
<P>
<HR WIDTH="100%"><B>> <I>db</I> del</B>
<P>There are no undocumented options.
<HR WIDTH="100%">
<B>> <I>db</I> join [-nosort] <I>db0.c0 db1.c0</I> ...</B>
<P>This command will invoke the <A HREF="../../docs/api_c/db_join.html">db_join</A>
function.&nbsp; After it successfully joins a database, we bind it to a
new Tcl command of the form <B><I>dbN.cX, </I></B>where X is an integer
starting at 0 (e.g. <B>db2.c0, db3.c0, </B>etc).&nbsp; We use the <I>Tcl_CreateObjCommand()&nbsp;</I>
to create the top level database function.&nbsp; It is through this cursor
handle that the user can access the joined data items.
<P>The options are:
<UL>
<LI>
<B>-nosort -</B> This flag causes DB not to sort the cursors based on the
number of data items they reference.&nbsp; It results in the DB_JOIN_NOSORT
flag being set.</LI>
</UL>
<P>
This command will invoke the
<A HREF="../../docs/api_c/db_create.html">db_create</A> function. If
the command is given the <B>-env</B> option, then we will accordingly
creating the database within the context of that environment. After it
successfully gets a handle to a database, we bind it to a new Tcl
command of the form <B><I>dbX, </I></B>where X is an integer starting
at 0 (e.g. <B>db0, db1, </B>etc).
<p>
We use the <I>Tcl_CreateObjCommand()</I> to create the top level
database function. It is through this handle that the user can access
all of the commands described in the <A HREF="#Database Commands">
Database Commands</A> section. Internally, the database handle
is sent as the <I>ClientData</I> portion of the new command set so that
all future database calls access the appropriate handle.
<P>
After parsing all of the optional arguments affecting the setup of the
database and making the appropriate calls to DB to manipulate those
values, we open the database for the user. It translates to the
<A HREF="../../docs/api_c/db_open.html">DB->open</A> method call after
parsing all of the various optional arguments. We automatically set the
DB_THREAD flag. The arguments are:
<HR WIDTH="100%">
<B>> <I>db</I> get_join [-nosort] {db key} {db key} ...</B>
<P>This command performs a join operation on the keys specified and returns
a list of the joined {key data} pairs.
<P>The options are:
<UL>
<LI>
<B>-nosort</B> This flag causes DB not to sort the cursors based on the
number of data items they reference.&nbsp; It results in the DB_JOIN_NOSORT
flag being set.</LI>
</UL>
<HR WIDTH="100%">
<B>> <I>db</I> keyrange [-txn <I>id</I>] key</B>
<P>This command returns the range for the given <B>key</B>.&nbsp; It returns
a list of 3 double elements of the form {<B><I>less equal greater</I></B>}
where <B><I>less</I></B> is the percentage of keys less than the given
key, <B><I>equal</I></B> is the percentage equal to the given key and <B><I>greater</I></B>
is the percentage greater than the given key.&nbsp; If the -txn option
is specified it performs this operation under transaction protection.
<HR WIDTH="100%"><B>> <I>db</I> put</B>
<P>The <B>undocumented</B> options are:
<dl>
<dt><B>-nodupdata</B><dd>
This flag causes DB not to insert the key/data pair if it already
exists, that is, both the key and data items are already in the
database. The -nodupdata flag may only be specified if the underlying
database has been configured to support sorted duplicates.
</dl>
<HR WIDTH="100%"><B>> <I>dbc</I> put</B>
<P>The <B>undocumented</B> options are:
<dl>
<dt><B>-nodupdata</B><dd>
This flag causes DB not to insert the key/data pair if it already
exists, that is, both the key and data items are already in the
database. The -nodupdata flag may only be specified if the underlying
database has been configured to support sorted duplicates.
</dl>
</BODY>
</HTML>

344
tcl/docs/env.html Normal file
View File

@@ -0,0 +1,344 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.75 [en] (X11; U; Linux 2.2.16-22 i686) [Netscape]">
</head>
<body>
<h2>
Environment Commands</h2>
Environments provide a structure for creating a consistent environment
for processes using one or more of the features of Berkeley DB.&nbsp; Unlike
some of the database commands, the environment commands are very low level.
<br>
<hr WIDTH="100%">
<p>The user may create and open a new DB environment&nbsp; by invoking:
<p><b>> berkdb env</b>
<br><b>&nbsp;&nbsp;&nbsp; [-cdb] [-cdb_alldb] [-lock] [-log] [-txn [nosync]]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-create] [-home<i> directory</i>] [-mode <i>mode</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-data_dir <i>directory</i>] [-log_dir <i>directory</i>]
[-tmp_dir <i>directory</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-nommap] [-private] [-recover] [-recover_fatal]
[-system_mem] [-errfile <i>filename</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-use_environ] [-use_environ_root] [-verbose
{<i>which </i>on|off}]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-region_init]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-cachesize {<i>gbytes bytes ncaches</i>}]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-mmapsize<i> size</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-log_max <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-log_buffer <i>size</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_conflict {<i>nmodes </i>{<i>matrix</i>}}]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_detect default|oldest|random|youngest]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_max <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_max_locks <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_max_lockers <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_max_objects <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-lock_timeout <i>timeout</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-overwrite]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-txn_max <i>max</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-txn_timeout <i>timeout</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-client_timeout <i>seconds</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-server_timeout <i>seconds</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-server <i>hostname</i>]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-rep_master] [-rep_client]</b>
<br><b>&nbsp;&nbsp;&nbsp; [-rep_transport <i>{ machineid sendproc }</i>]</b>
<br>&nbsp;
<p>This command opens up an environment.&nbsp;&nbsp; We automatically set
the DB_THREAD and the DB_INIT_MPOOL flags.&nbsp; The arguments are:
<ul>
<li>
<b>-cdb</b> selects the DB_INIT_CDB flag for Concurrent Data Store</li>
<li>
<b>-cdb_alldb</b> selects the DB_CDB_ALLDB flag for Concurrent Data Store</li>
<li>
<b>-lock</b> selects the DB_INIT_LOCK flag for the locking subsystem</li>
<li>
<b>-log</b> selects the DB_INIT_LOG flag for the logging subsystem</li>
<li>
<b>-txn</b> selects the DB_INIT_TXN, DB_INIT_LOCK and DB_INIT_LOG flags
for the transaction subsystem.&nbsp; If <b>nosync</b> is specified, then
it will also select DB_TXN_NOSYNC to indicate no flushes of log on commits</li>
<li>
<b>-create </b>selects the DB_CREATE flag to create underlying files</li>
<li>
<b>-home <i>directory </i></b>selects the home directory of the environment</li>
<li>
<b>-data_dir <i>directory </i></b>selects the data file directory of the
environment by calling <a href="../../docs/api_c/env_set_data_dir.html">DBENV->set_data_dir</a>.</li>
<li>
<b>-log_dir <i>directory </i></b>selects the log file directory of the
environment&nbsp; by calling <a href="../../docs/api_c/env_set_lg_dir.html">DBENV->set_lg_dir</a>.</li>
<li>
<b>-tmp_dir <i>directory </i></b>selects the temporary file directory of
the environment&nbsp; by calling <a href="../../docs/api_c/env_set_tmp_dir.so">DBENV->set_tmp_dir</a>.</li>
<li>
<b>-mode <i>mode </i></b>sets the permissions of created files to <b><i>mode</i></b></li>
<li>
<b>-nommap</b> selects the DB_NOMMAP flag to disallow using mmap'ed files</li>
<li>
<b>-private</b> selects the DB_PRIVATE flag for a private environment</li>
<li>
<b>-recover</b> selects the DB_RECOVER flag for recovery</li>
<li>
<b>-recover_fatal</b> selects the DB_RECOVER_FATAL flag for catastrophic
recovery</li>
<li>
<b>-system_mem</b> selects the DB_SYSTEM_MEM flag to use system memory</li>
<li>
<b>-errfile </b>specifies the error file to use for this environment to
<b><i>filename</i></b>
by calling <a href="../../docs/api_c/env_set_errfile.html">DBENV->set_errfile</a><b><i>.
</i></b>If
the file already exists then we will append to the end of the file</li>
<li>
<b>-use_environ</b> selects the DB_USE_ENVIRON flag to affect file naming</li>
<li>
<b>-use_environ_root</b> selects the DB_USE_ENVIRON_ROOT flag to have the
root environment affect file naming</li>
<li>
<b>-verbose</b> produces verbose error output for the given which subsystem,
using the <a href="../../docs/api_c/dbenv_set_verbose.html">DBENV->set_verbose</a>
method.&nbsp;&nbsp; See the description of <a href="#> <env> verbose which on|off">verbose</a>
below for valid <b><i>which </i></b>values</li>
<li>
<b>-region_init </b>specifies that the user wants to page fault the region
in on startup using the <a href="../../docs/api_c/env_set_region_init.html">DBENV->set_region_init</a>
method call</li>
<li>
<b>-cachesize </b>sets the size of the database cache to the size&nbsp;
specified by <b><i>gbytes </i></b>and <b><i>bytes, </i></b>broken up into
<b><i>ncaches</i></b>
number of caches using the <a href="../../docs/api_c/env_set_cachesize.html">DBENV->set_cachesize</a>
method</li>
<li>
<b>-mmapsize </b>sets the size of the database page to <b><i>size </i></b>using
the <a href="../../docs/api_c/env_set_mp_mmapsize.html">DBENV->set_mp_mmapsize</a>
method</li>
<li>
<b>-log_max </b>sets the maximum size of the log file to <b><i>max</i></b>
using the <a href="../../docs/api_c/env_set_lg_max.html">DBENV->set_lg_max</a>
call</li>
<li>
<b>-log_regionmax </b>sets the size of the log region to <b><i>max</i></b>
using the <a href="../../docs/api_c/env_set_lg_regionmax.html">DBENV->set_lg_regionmax</a>
call</li>
<li>
<b>-log_buffer </b>sets the size of the log file in bytes to <b><i>size</i></b>
using the <a href="../../docs/api_c/env_set_lg_bsize.html">DBENV->set_lg_bsize</a>
call</li>
<li>
<b>-lock_conflict </b>sets the number of lock modes to <b><i>nmodes</i></b>
and sets the locking policy for those modes to the <b><i>conflict_matrix</i></b>
given using the <a href="../../docs/api_c/env_set_lk_conflict.html">DBENV->set_lk_conflict</a>
method call</li>
<li>
<b>-lock_detect </b>sets the deadlock detection policy to the given policy
using the <a href="../../docs/env_set_lk_detect.html">DBENV->set_lk_detect</a>
method call.&nbsp; The policy choices are:</li>
<ul>
<li>
<b>default</b> selects the DB_LOCK_DEFAULT policy for default detection</li>
<li>
<b>oldest </b>selects DB_LOCK_OLDEST to abort the oldest locker on a deadlock</li>
<li>
<b>random</b> selects DB_LOCK_RANDOM to abort a random locker on a deadlock</li>
<li>
<b>youngest</b> selects DB_LOCK_YOUNGEST to abort the youngest locker on
a deadlock</li>
</ul>
<li>
<b>-lock_max_locks </b>sets the maximum number of locks to <b><i>max </i></b>using
the <a href="../../docs/api_c/env_set_lk_max_locks.html">DBENV->set_lk_max_locks</a>
method call</li>
<li>
<b>-lock_max_lockers </b>sets the maximum number of locking entities to
<b><i>max
</i></b>using the <a href="../../docs/api_c/env_set_lk_max_lockers.html">DBENV->set_lk_max_lockers</a>
method call</li>
<li>
<b>-lock_max_objects </b>sets the maximum number of simultaneously locked
objects to <b><i>max </i></b>using the <a href="../../docs/api_c/env_set_lk_max_objects.html">DBENV->set_lk_max_objects</a>
method call</li>
<li>
<b>-lock_timeout </b>sets the timeout for locks in the environment</li>
<li>
<b>-overwrite </b>sets DB_OVERWRITE flag</li>
<li>
<b>-txn_max </b>sets the maximum size of the transaction table to <b><i>max</i></b>
using the <a href="../../docs/api_c/env_set_txn_max.html">DBENV->set_txn_max</a>
method call</li>
<li>
<b>-txn_timeout </b>sets the timeout for transactions in the environment</li>
<li>
<b>-client_timeout</b> sets the timeout value for the client waiting for
a reply from the server for RPC operations to <b><i>seconds</i></b>.</li>
<li>
<b>-server_timeout</b> sets the timeout value for the server to determine
an idle client is gone to <b><i>seconds</i></b>.</li>
<li>
<b>-server </b>specifies the <b><i>hostname</i></b> of the server
to connect to in the <a href="../../docs/api_c/env_set_server.html">DBENV->set_server</a>
call.</li>
<li>
<b>-rep_client </b>sets the newly created environment to be a
replication client, using the <a href="../../docs/api_c/rep_client.html">
DBENV->rep_client</a> call.</li>
<li>
<b>-rep_master </b>sets the newly created environment to be a
replication master, using the <a href="../../docs/api_c/rep_master.html">
DBENV->rep_master</a> call.</li>
<li>
<b>-rep_transport </b>specifies the replication transport function,
using the
<a href="../../docs/api_c/rep_transport.html">DBENV->rep_set_transport</a>
call. This site's machine ID is set to <b><i>machineid</i></b> and
the send function, a Tcl proc, is set to <b><i>sendproc</i></b>.</li>
</ul>
This command will invoke the <a href="../../docs/api_c/env_create.html">db_env_create</a>
function.&nbsp; After it successfully gets a handle to an environment,
we bind it to a new Tcl command of the form <b><i>envX</i></b>, where X
is an integer starting at&nbsp; 0 (e.g. <b>env0, env1, </b>etc).&nbsp;
We use the <i>Tcl_CreateObjCommand()</i> to create the top level environment
command function.&nbsp; It is through this handle that the user can access
all the commands described in the <a href="#Environment Commands">Environment
Commands</a> section.&nbsp; Internally, the handle we get back from DB
will be stored as the <i>ClientData</i> portion of the new command set
so that all future environment calls will have that handle readily available.&nbsp;
Then we call the <a href="../../docs/api_c/env_open.html">DBENV->open</a>
method call and possibly some number of setup calls as described above.
<p>
<hr WIDTH="100%">
<br><a NAME="> <env> verbose which on|off"></a><b>> &lt;env> verbose <i>which</i>
on|off</b>
<p>This command controls the use of debugging output for the environment.&nbsp;
This command directly translates to a call to the <a href="../../docs/api_c/dbenv_set_verbose.html">DBENV->set_verbose</a>
method call.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.&nbsp; The user specifies
<b><i>which</i></b>
subsystem to control, and indicates whether debug messages should be turned
<b>on</b>
or <b>off</b> for that subsystem.&nbsp; The value of <b><i>which</i></b>
must be one of the following:
<ul>
<li>
<b>deadlock </b>- Chooses the deadlocking code by using the DB_VERB_DEADLOCK
value</li>
<li>
<b>recovery </b>- Chooses the recovery code by using the DB_VERB_RECOVERY
value</li>
<li>
<b>wait </b>- Chooses the waitsfor code by using the DB_VERB_WAITSFOR value</li>
</ul>
<hr WIDTH="100%">
<p><a NAME="> <env> close"></a><b>> &lt;env> close</b>
<p>This command closes an environment and deletes the handle.&nbsp; This
command directly translates to a call to the <a href="../../docs/api_c/env_close.html">DBENV->close</a>
method call.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.
<p>Additionally, since the handle is no longer valid, we will call <i>Tcl_DeleteCommand()
</i>so
that further uses of the handle will be dealt with properly by Tcl itself.
<p>Also, the close command will automatically abort any <a href="txn.html">transactions</a>
and close any <a href="mpool.html">mpool</a> memory files.&nbsp; As such
we must maintain a list of open transaction and mpool handles so that we
can call <i>Tcl_DeleteCommand</i> on those as well.
<p>
<hr WIDTH="100%">
<b>> berkdb envremove<br>
[-data_dir <i>directory</i>]<br>
[-force]<br>
[-home <i>directory</i>]<br>
[-log_dir <i>directory</i>]<br>
[-overwrite]<br>
[-tmp_dir <i>directory</i>]<br>
[-use_environ]<br>
[-use_environ_root]</b>
<p>This command removes the environment if it is not in use and deletes
the handle.&nbsp; This command directly translates to a call to the <a href="../../docs/api_c/env_remove.html">DBENV->remove</a>
method call.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.&nbsp; The arguments are:
<ul>
<li>
<b>-force</b> selects the DB_FORCE flag to remove even if other processes
have the environment open</li>
<li>
<b>-home <i>directory</i> </b>specifies the home directory of the environment</li>
<li>
<b>-data_dir <i>directory </i></b>selects the data file directory of the
environment by calling <a href="../../docs/api_c/env_set_data_dir.html">DBENV->set_data_dir</a>.</li>
<li>
<b>-log_dir <i>directory </i></b>selects the log file directory of the
environment&nbsp; by calling <a href="../../docs/api_c/env_set_lg_dir.html">DBENV->set_lg_dir</a>.</li>
<li>
<b>-overwrite </b>sets DB_OVERWRITE flag</li>
<li>
<b>-tmp_dir <i>directory </i></b>selects the temporary file directory of
the environment&nbsp; by calling <a href="../../docs/api_c/env_set_tmp_dir.so">DBENV->set_tmp_dir</a>.</li>
<li>
<b>-use_environ </b>selects the DB_USE_ENVIRON flag to affect file naming</li>
<li>
<b>-use_environ_root</b> selects the DB_USE_ENVIRON_ROOT flag to affect
file naming</li>
</ul>
</body>
</html>

168
tcl/docs/historic.html Normal file
View File

@@ -0,0 +1,168 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 2.2.8-19990120-SNAP i386) [Netscape]">
</HEAD>
<BODY>
<H2>
<A NAME="Compatibility Commands"></A>Compatibility Commands</H2>
The compatibility commands for old Dbm and Ndbm are described in the <A HREF="../../docs/api_c/dbm.html">dbm</A>
manpage.
<P><B>> berkdb dbminit <I>filename</I></B>
<P>This command will invoke the dbminit function.&nbsp;&nbsp; <B><I>Filename</I></B>
is used as the name of the database.
<P>
<HR WIDTH="100%"><B>> berkdb dbmclose</B>
<P>This command will invoke the dbmclose function.
<P>
<HR WIDTH="100%"><B>> berkdb fetch <I>key</I></B>
<P>This command will invoke the fetch function.&nbsp;&nbsp; It will return
the data associated with the given <B><I>key </I></B>or a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb store <I>key data</I></B>
<P>This command will invoke the store function.&nbsp;&nbsp; It will store
the <B><I>key/data</I></B> pair.&nbsp; It will return a 0 on success or
throw a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb delete <I>key</I></B>
<P>This command will invoke the deletet function.&nbsp;&nbsp; It will delete
the <B><I>key</I></B> from the database.&nbsp; It will return a 0 on success
or throw a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb firstkey</B>
<P>This command will invoke the firstkey function.&nbsp;&nbsp; It will
return the first key in the database or a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb nextkey <I>key</I></B>
<P>This command will invoke the nextkey function.&nbsp;&nbsp; It will return
the next key after the given <B><I>key</I></B> or a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb hcreate <I>nelem</I></B>
<P>This command will invoke the hcreate function with <B><I>nelem</I></B>
elements.&nbsp; It will return a 0 on success or a Tcl error.
<P>
<HR WIDTH="100%"><B>> berkdb hsearch <I>key data action</I></B>
<P>This command will invoke the hsearch function with <B><I>key</I></B>
and <B><I>data</I></B>.&nbsp; The <B><I>action</I></B> must be either <B>find</B>
or <B>enter</B>.&nbsp; If it is <B>find</B>, it will return the resultant
data.&nbsp; If it is <B>enter</B>, it will return a 0 on success or a Tcl
error.
<P>
<HR WIDTH="100%"><B>> berkdb hdestroy</B>
<P>This command will invoke the hdestroy function.&nbsp; It will return
a 0.
<HR WIDTH="100%"><B>> berkdb ndbm_open [-create] [-rdonly] [-truncate]
[-mode
<I>mode</I>] [--] <I>filename</I></B>
<P>This command will invoke the dbm_open function.&nbsp;&nbsp;&nbsp; After
it successfully gets a handle to a database, we bind it to a new Tcl command
of the form <B><I>ndbmX, </I></B>where X is an integer starting at 0 (e.g.
<B>ndbm0,
ndbm1, </B>etc).&nbsp; We use the <I>Tcl_CreateObjCommand()&nbsp;</I> to
create the top level database function.&nbsp; It is through this handle
that the user can access all of the commands described below.&nbsp; Internally,
the database handle is sent as the <I>ClientData</I> portion of the new
command set so that all future database calls access the appropriate handle.
<P>The arguments are:
<UL>
<LI>
<B>-- </B>- Terminate the list of options and use remaining arguments as
the file or subdb names (thus allowing the use of filenames beginning with
a dash '-')</LI>
<LI>
<B>-create</B> selects the O_CREAT flag&nbsp; to create underlying files</LI>
<LI>
<B>-rdonly</B> selects the O_RDONLY flag for opening in read-only mode</LI>
<LI>
<B>-truncate</B> selects the O_TRUNC flag to truncate the database</LI>
<LI>
<B>-mode<I> mode</I></B> specifies the mode for created files</LI>
<LI>
<B><I>filename</I></B> indicates the name of the database</LI>
</UL>
<P><BR>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> close</B>
<P>This command closes the database and renders the handle invalid.&nbsp;&nbsp;
This command directly translates to the dbm_close function call.&nbsp;
It returns either a 0 (for success),&nbsp; or it throws a Tcl error with
a system message.
<P>Additionally, since the handle is no longer valid, we will call <I>Tcl_DeleteCommand()
</I>so
that further uses of the handle will be dealt with properly by Tcl itself.&nbsp;
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> clearerr</B>
<P>This command clears errors&nbsp; the database.&nbsp;&nbsp; This command
directly translates to the dbm_clearerr function call.&nbsp; It returns
either a 0 (for success),&nbsp; or it throws a Tcl error with a system
message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> delete <I>key</I></B>
<P>This command deletes the <B><I>key</I></B> from thedatabase.&nbsp;&nbsp;
This command directly translates to the dbm_delete function call.&nbsp;
It returns either a 0 (for success),&nbsp; or it throws a Tcl error with
a system message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> dirfno</B>
<P>This command directly translates to the dbm_dirfno function call.&nbsp;
It returns either resultts,&nbsp; or it throws a Tcl error with a system
message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> error</B>
<P>This command returns the last error.&nbsp;&nbsp; This command directly
translates to the dbm_error function call.&nbsp; It returns an error string..
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> fetch <I>key</I></B>
<P>This command gets the given <B><I>key</I></B> from the database.&nbsp;&nbsp;
This command directly translates to the dbm_fetch function call.&nbsp;
It returns either the data,&nbsp; or it throws a Tcl error with a system
message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> firstkey</B>
<P>This command returns the first key in the database.&nbsp;&nbsp; This
command directly translates to the dbm_firstkey function call.&nbsp; It
returns either the key,&nbsp; or it throws a Tcl error with a system message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> nextkey</B>
<P>This command returns the next key in the database.&nbsp;&nbsp; This
command directly translates to the dbm_nextkey function call.&nbsp; It
returns either the key,&nbsp; or it throws a Tcl error with a system message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> pagfno</B>
<P>This command directly translates to the dbm_pagfno function call.&nbsp;
It returns either resultts,&nbsp; or it throws a Tcl error with a system
message.
<BR>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> rdonly</B>
<P>This command changes the database to readonly.&nbsp;&nbsp; This command
directly translates to the dbm_rdonly function call.&nbsp; It returns either
a 0 (for success),&nbsp; or it throws a Tcl error with a system message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;ndbm> store <I>key data </I>insert|replace</B>
<P>This command puts the given <B><I>key</I></B> and <B><I>data</I></B>
pair into the database.&nbsp;&nbsp; This command directly translates to
the dbm_store function call.&nbsp; It will either <B>insert</B> or <B>replace</B>
the data based on the action given in the third argument.&nbsp; It returns
either a 0 (for success),&nbsp; or it throws a Tcl error with a system
message.
<BR>
<HR WIDTH="100%">
</BODY>
</HTML>

50
tcl/docs/index.html Normal file
View File

@@ -0,0 +1,50 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 2.2.8-19990120-SNAP i386) [Netscape]">
</HEAD>
<BODY>
<CENTER>
<H1>
Complete Tcl Interface for Berkeley DB</H1></CENTER>
<UL type=disc>
<LI>
<A HREF="../../docs/api_tcl/tcl_index.html">General use Berkeley DB commands</A></LI>
</UL>
<UL type=disc>
<LI>
<A HREF="./env.html">Environment commands</A></LI>
<LI>
<A HREF="./lock.html">Locking commands</A></LI>
<LI>
<A HREF="./log.html">Logging commands</A></LI>
<LI>
<A HREF="./mpool.html">Memory Pool commands</A></LI>
<LI>
<A HREF="./rep.html">Replication commands</A></LI>
<LI>
<A HREF="./txn.html">Transaction commands</A></LI>
</UL>
<UL>
<LI>
<A HREF="./db.html">Access Method commands</A></LI>
<LI>
<A HREF="./test.html">Debugging and Testing</A></LI>
<LI>
<A HREF="./historic.html">Compatibility commands</A></LI>
<LI>
<A HREF="./library.html">Convenience commands</A></LI>
</UL>

26
tcl/docs/library.html Normal file
View File

@@ -0,0 +1,26 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 2.2.8-19990120-SNAP i386) [Netscape]">
</HEAD>
<BODY>
<HR WIDTH="100%">
<H2>
<A NAME="Convenience Commands"></A>Convenience Commands</H2>
The convenience commands are provided for ease of use with the DB test
suite.
<P><B>> berkdb rand</B>
<P>This command will invoke the rand function and return the random number.
<P>
<HR WIDTH="100%"><B>> berkdb random_int <I>low high</I></B>
<P>This command will invoke the rand function and return a number between
<B><I>low</I></B>
and <B><I>high</I></B>.
<P>
<HR WIDTH="100%">
<P><B>> berkdb srand <I>seed</I></B>
<P>This command will invoke the srand function with the given <B><I>seed</I></B>
and return 0.
<P>
<HR WIDTH="100%">

206
tcl/docs/lock.html Normal file
View File

@@ -0,0 +1,206 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.75 [en] (X11; U; Linux 2.2.16-22 i686) [Netscape]">
</head>
<body>
<h2>
<a NAME="Locking Commands"></a>Locking Commands</h2>
Most locking commands work with the environment handle.&nbsp; However,
when a user gets a lock we create a new lock handle that they then use
with in a similar manner to all the other handles to release the lock.&nbsp;
We present the general locking functions first, and then those that manipulate
locks.
<p><b>> &lt;env> lock_detect [default|oldest|youngest|random]</b>
<p>This command runs the deadlock detector.&nbsp; It directly translates
to the <a href="../../docs/api_c/lock_detect.html">lock_detect</a> DB call.&nbsp;
It returns either a 0 (for success), a DB error message or it throws a
Tcl error with a system message.&nbsp; The first argument sets the policy
for deadlock as follows:
<ul>
<li>
<b>default</b> selects the DB_LOCK_DEFAULT policy for default detection
(default if not specified)</li>
<li>
<b>oldest </b>selects DB_LOCK_OLDEST to abort the oldest locker on a deadlock</li>
<li>
<b>random</b> selects DB_LOCK_RANDOM to abort a random locker on a deadlock</li>
<li>
<b>youngest</b> selects DB_LOCK_YOUNGEST to abort the youngest locker on
a deadlock</li>
</ul>
<hr WIDTH="100%">
<br><b>> &lt;env> lock_stat</b>
<p>This command returns a list of name/value pairs where the names correspond
to the C-structure field names of DB_LOCK_STAT and the values are the data
returned.&nbsp; This command is a direct translation of the <a href="../../docs/api_c/lock_stat.html">lock_stat</a>
DB call.
<hr WIDTH="100%">
<br><a NAME="> <env> lock_id"></a><b>> &lt;env> lock_id</b>
<p>This command returns a unique locker ID value.&nbsp; It directly translates
to the <a href="../../docs/api_c/lock_id.html">lock_id</a> DB call.
<br>
<hr WIDTH="100%">
<br><a NAME="> <env> lock_id"></a><b>> &lt;env> lock_id_free&nbsp; </b><i>locker</i>
<p>This command frees the locker allockated by the lock_id call. It directly
translates to the&nbsp; <a href="../../docs/api_c/lock_id.html">lock_id_free
</a>DB
call.
<hr WIDTH="100%">
<br><a NAME="> <env> lock_id"></a><b>> &lt;env> lock_id_set&nbsp; </b><i>current
max</i>
<p>This&nbsp; is a diagnostic command to set the locker id that will get
allocated next and the maximum id that
<br>will trigger the id reclaim algorithm.
<hr WIDTH="100%">
<br><a NAME="> <env> lock_get"></a><b>> &lt;env> lock_get [-nowait]<i>lockmode
locker obj</i></b>
<p>This command gets a lock. It will invoke the <a href="../../docs/api_c/lock_get.html">lock_get</a>
function.&nbsp; After it successfully gets a handle to a lock, we bind
it to a new Tcl command of the form <b><i>$env.lockX</i></b>, where X is
an integer starting at&nbsp; 0 (e.g. <b>$env.lock0, $env.lock1, </b>etc).&nbsp;
We use the <i>Tcl_CreateObjCommand()</i> to create the top level locking
command function.&nbsp; It is through this handle that the user can release
the lock.&nbsp; Internally, the handle we get back from DB will be stored
as the <i>ClientData</i> portion of the new command set so that future
locking calls will have that handle readily available.
<p>The arguments are:
<ul>
<li>
<b><i>locker</i></b> specifies the locker ID returned from the <a href="#> <env> lock_id">lock_id</a>
command</li>
<li>
<b><i>obj</i></b> specifies an object to lock</li>
<li>
the <b><i>lock mode</i></b> is specified as one of the following:</li>
<ul>
<li>
<b>ng </b>specifies DB_LOCK_NG for not granted (always 0)</li>
<li>
<b>read</b> specifies DB_LOCK_READ for a read (shared) lock</li>
<li>
<b>write</b> specifies DB_LOCK_WRITE for an exclusive write lock</li>
<li>
<b>iwrite </b>specifies DB_LOCK_IWRITE for intent for exclusive write lock</li>
<li>
<b>iread </b>specifies DB_LOCK_IREAD for intent for shared read lock</li>
<li>
<b>iwr </b>specifies DB_LOCK_IWR for intent for eread and write lock</li>
</ul>
<li>
<b>-nowait</b> selects the DB_LOCK_NOWAIT to indicate that we do not want
to wait on the lock</li>
</ul>
<hr WIDTH="100%">
<br><b>> &lt;lock> put</b>
<p>This command releases the lock referenced by the command.&nbsp; It is
a direct translation of the <a href="../../docs/api_c/lock_put.html">lock_put</a>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.&nbsp; Additionally, since
the handle is no longer valid, we will call
<i>Tcl_DeleteCommand()
</i>so
that further uses of the handle will be dealt with properly by Tcl itself.
<br>
<hr WIDTH="100%">
<br><a NAME="> <env> lock_vec"></a><b>> &lt;env> lock_vec [-nowait] <i>locker
</i>{get|put|put_all|put_obj
[<i>obj</i>] [<i>lockmode</i>] [<i>lock</i>]} ...</b>
<p>This command performs a series of lock calls.&nbsp; It is a direct translation
of the <a href="../../docs/api_c/lock_vec.html">lock_vec</a> function.&nbsp;
This command will return a list of the return values from each operation
specified in the argument list.&nbsp; For the 'put' operations the entry
in the return value list is either a 0 (for success) or an error.&nbsp;
For the 'get' operation, the entry is the lock widget handle, <b>$env.lockN</b>
(as described above in <a href="#> <env> lock_get">&lt;env> lock_get</a>)
or an error.&nbsp; If an error occurs, the return list will contain the
return values for all the successful operations up the erroneous one and
the error code for that operation.&nbsp; Subsequent operations will be
ignored.
<p>As for the other operations, if we are doing a 'get' we will create
the commands and if we are doing a 'put' we will have to delete the commands.&nbsp;
Additionally, we will have to do this after the call to the DB lock_vec
and iterate over the results, creating and/or deleting Tcl commands.&nbsp;
It is possible that we may return a lock widget from a get operation that
is considered invalid, if, for instance, there was a <b>put_all</b> operation
performed later in the vector of operations.&nbsp; The arguments are:
<ul>
<li>
<b><i>locker</i></b> specifies the locker ID returned from the <a href="#> <env> lock_id">lock_id</a>
command</li>
<li>
<b>-nowait</b> selects the DB_LOCK_NOWAIT to indicate that we do not want
to wait on the lock</li>
<li>
the lock vectors are tuple consisting of {an operation, lock object, lock
mode, lock handle} where what is required is based on the operation desired:</li>
<ul>
<li>
<b>get</b> specifes DB_LOCK_GET to get a lock.&nbsp; Requires a tuple <b>{get
<i>objmode</i>}
</b>where
<b><i>mode</i></b>
is:</li>
<ul>
<li>
<b>ng </b>specifies DB_LOCK_NG for not granted (always 0)</li>
<li>
<b>read</b> specifies DB_LOCK_READ for a read (shared) lock</li>
<li>
<b>write</b> specifies DB_LOCK_WRITE for an exclusive write lock</li>
<li>
<b>iwrite </b>specifies DB_LOCK_IWRITE for intent for exclusive write lock</li>
<li>
<b>iread </b>specifies DB_LOCK_IREAD for intent for shared read lock</li>
<li>
<b>iwr </b>specifies DB_LOCK_IWR for intent for eread and write lock</li>
</ul>
<li>
<b>put</b> specifies DB_LOCK_PUT to release a <b><i>lock</i></b>.&nbsp;
Requires a tuple <b>{put <i>lock}</i></b></li>
<li>
<b>put_all </b>specifies DB_LOCK_PUT_ALL to release all locks held by <b><i>locker</i></b>.&nbsp;
Requires a tuple <b>{put_all}</b></li>
<li>
<b>put_obj</b> specifies DB_LOCK_PUT_OBJ to release all locks held by <b><i>locker</i></b>
associated with the given <b><i>obj</i></b>.&nbsp; Requires a tuple <b>{put_obj
<i>obj}</i></b></li>
</ul>
</ul>
<hr WIDTH="100%">
<br><a NAME="> <env> lock_vec"></a><b>> &lt;env> lock_timeout <i>timeout</i></b>
<p>This command sets the lock timeout for all future locks in this environment.&nbsp;
The timeout is in micorseconds.
<br>&nbsp;
<br>&nbsp;
</body>
</html>

123
tcl/docs/log.html Normal file
View File

@@ -0,0 +1,123 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 3.3-RELEASE i386) [Netscape]">
</HEAD>
<BODY>
<H2>
<A NAME="Logging Commands"></A>Logging Commands</H2>
Logging commands work from the environment handle to control the use of
the log files.&nbsp; Log files are opened when the environment is opened
and closed when the environment is closed.&nbsp; In all of the commands
in the logging subsystem that take or return a log sequence number, it
is of the form:
<BR><B>{<I>fileid offset</I>}</B>
<BR>where the <B><I>fileid</I></B> is an identifier of the log file, as
returned from the <A HREF="#> <env> log_get">log_get</A> call.
<P><B>> &lt;env> log_archive [-arch_abs] [-arch_data] [-arch_log]</B>
<P>This command returns&nbsp; a list of log files that are no longer in
use.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/log_archive.html">log_archive</A>
function. The arguments are:
<UL>
<LI>
<B>-arch_abs </B>selects DB_ARCH_ABS to return all pathnames as absolute
pathnames</LI>
<LI>
<B>-arch_data </B>selects DB_ARCH_DATA to return a list of database files</LI>
<LI>
<B>-arch_log </B>selects DB_ARCH_LOG to return a list of log files</LI>
</UL>
<HR WIDTH="100%">
<BR><B>> &lt;env> log_compare <I>lsn1 lsn2</I></B>
<P>This command compares two log sequence numbers, given as <B><I>lsn1</I></B>
and <B><I>lsn2</I></B>.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/log_compare.html">log_compare</A>
function.&nbsp; It will return a -1, 0, 1 to indicate if <B><I>lsn1</I></B>
is less than, equal to or greater than <B><I>lsn2</I></B> respectively.
<BR>
<HR WIDTH="100%">
<BR><B>> &lt;env> log_file <I>lsn</I></B>
<P>This command returns&nbsp; the file name associated with the given <B><I>lsn</I></B>.&nbsp;
It is a direct call to the <A HREF="../../docs/api_c/log_file.html">log_file</A>
function.
<BR>
<HR WIDTH="100%">
<BR><B>> &lt;env> log_flush [<I>lsn</I>]</B>
<P>This command&nbsp; flushes the log up to the specified <B><I>lsn</I></B>
or flushes all records if none is given&nbsp; It is a direct call to the
<A HREF="../../docs/api_c/log_flush.html">log_flush</A>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.
<BR>
<HR WIDTH="100%">
<BR><A NAME="<env> log_get"></A><B>> &lt;env> log_get<I> </I>[-checkpoint]
[-current] [-first] [-last] [-next] [-prev] [-set <I>lsn</I>]</B>
<P>This command retrieves a record from the log according to the <B><I>lsn</I></B>
given and returns it and the data.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/log_get.html">log_get</A>
function.&nbsp; It is a way of implementing a manner of log iteration similar
to <A HREF="../../docs/api_tcl/db_cursor.html">cursors</A>.&nbsp;&nbsp;
The information we return is similar to database information.&nbsp; We
return a list where the first item is the LSN (which is a list itself)
and the second item is the data.&nbsp; So it looks like, fully expanded,
<B>{{<I>fileid</I>
<I>offset</I>}
<I>data</I>}.</B>&nbsp;
In the case where DB_NOTFOUND is returned, we return an empty list <B>{}</B>.&nbsp;
All other errors return a Tcl error.&nbsp; The arguments are:
<UL>
<LI>
<B>-checkpoint </B>selects the DB_CHECKPOINT flag to return the LSN/data
pair of the last record written through <A HREF="#> <env> log_put">log_put</A>
with DB_CHECKPOINT specified</LI>
<LI>
<B>-current</B> selects the DB_CURRENT flag to return the current record</LI>
<LI>
<B>-first</B> selects the DB_FIRST flag to return the first record in the
log.</LI>
<LI>
<B>-last </B>selects the DB_LAST flag to return the last record in the
log.</LI>
<LI>
<B>-next</B> selects the DB_NEXT flag to return the next record in the
log.</LI>
<LI>
<B>-prev </B>selects the DB_PREV flag to return the&nbsp; previous record
in the log.</LI>
<LI>
<B>-set</B> selects the DB_SET flag to return the record specified by the
given <B><I>lsn</I></B></LI>
</UL>
<HR WIDTH="100%">
<BR><A NAME="> <env> log_put"></A><B>> &lt;env> log_put<I> </I>[-checkpoint]
[-flush] <I>record</I></B>
<P>This command stores a <B><I>record</I></B> into the log and returns
the LSN of the log record.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/log_put.html">log_put</A>
function.&nbsp; It returns either an LSN or it throws a Tcl error with
a system message.&nbsp;<B> </B>The arguments are:
<UL>
<LI>
<B>-checkpoint </B>selects the DB_CHECKPOINT flag</LI>
<LI>
<B>-flush </B>selects the DB_FLUSH flag to flush the log to disk.</LI>
</UL>
<HR WIDTH="100%">
<BR><B>> &lt;env> log_stat</B>
<P>This command returns&nbsp; the statistics associated with the logging
subsystem.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/log_stat.html">log_stat</A>
function.&nbsp; It returns a list of name/value pairs of the DB_LOG_STAT
structure.
</BODY>
</HTML>

189
tcl/docs/mpool.html Normal file
View File

@@ -0,0 +1,189 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 2.2.8-19990120-SNAP i386) [Netscape]">
</HEAD>
<BODY>
<H2>
<A NAME="Memory Pool Commands"></A>Memory Pool Commands</H2>
Memory pools are used in a manner similar to the other subsystems.&nbsp;
We create a handle to the pool and&nbsp; then use it for a variety of operations.&nbsp;
Some of the memory pool commands use the environment instead. Those are
presented first.
<P><B>> &lt;env> mpool_stat</B>
<P>This command returns&nbsp; the statistics associated with the memory
pool subsystem.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/memp_stat.html">memp_stat</A>
function.&nbsp; It returns a list of name/value pairs of the DB_MPOOL_STAT
structure.
<BR>
<HR WIDTH="100%">
<BR><B>> &lt;env> mpool_sync <I>lsn</I></B>
<P>This command flushes the memory pool for all pages with a log sequence
number less than <B><I>lsn</I></B>.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/memp_sync.html">memp_sync&nbsp;</A>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.
<BR>
<HR WIDTH="100%">
<BR><B>> &lt;env> mpool_trickle <I>percent</I></B>
<P>This command tells DB to ensure that at least <B><I>percent</I></B>
percent of the pages are clean by writing out enough to dirty pages to
achieve that percentage.&nbsp; It is a direct call to the <A HREF="../../docs/api_c/memp_trickle.html">memp_trickle</A>
function.&nbsp; The command will return the number of pages actually written.&nbsp;
It returns either the number of pages on success, or it throws a Tcl error
with a system message.
<BR>
<HR WIDTH="100%">
<P><B>> &lt;env> mpool [-create] [-nommap] [-rdonly] [-mode <I>mode</I>]
-pagesize <I>size</I> [<I>file</I>]</B>
<P>This command creates a new memory pool.&nbsp; It invokes the <A HREF="../../docs/api_c/memp_fopen.html">memp_fopen</A>
function.&nbsp; After it successfully gets a handle to a memory pool, we
bind it to a new Tcl command of the form <B><I>$env.mpX</I></B>, where
X is an integer starting at&nbsp; 0 (e.g. <B>$env.mp0, $env.mp1, </B>etc).&nbsp;
We use the <I>Tcl_CreateObjCommand()</I> to create the top level memory
pool functions.&nbsp; It is through this handle that the user can manipulate
the pool.&nbsp; Internally, the handle we get back from DB will be stored
as the <I>ClientData</I> portion of the new command set so that future
memory pool calls will have that handle readily available.&nbsp; Additionally,
we need to maintain this handle in relation to the environment so that
if the user calls <A HREF="../../docs/api_tcl/env_close.html">&lt;env> close</A> without closing
the memory pool we can properly clean up.&nbsp; The arguments are:
<UL>
<LI>
<B><I>file</I></B> is the name of the file to open</LI>
<LI>
<B>-create </B>selects the DB_CREATE flag to create underlying file</LI>
<LI>
<B>-mode <I>mode </I></B>sets the permissions of created file to <B><I>mode</I></B></LI>
<LI>
<B>-nommap</B> selects the DB_NOMMAP flag to disallow using mmap'ed files</LI>
<LI>
<B>-pagesize</B> sets the underlying file page size to <B><I>size</I></B></LI>
<LI>
<B>-rdonly </B>selects the DB_RDONLY flag for read only access</LI>
</UL>
<HR WIDTH="100%">
<BR><B>> &lt;mp> close</B>
<P>This command closes the memory pool.&nbsp; It is a direct call to the
<A HREF="../../docs/api_c/memp_fclose.html">memp_close</A>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.
<P>Additionally, since the handle is no longer valid, we will call
<I>Tcl_DeleteCommand()
</I>so
that further uses of the handle will be dealt with properly by Tcl itself.&nbsp;
We must also remove the reference to this handle from the environment.&nbsp;
We will go through the list of pinned pages that were acquired by the <A HREF="#> <mp> get">get</A>
command and
<A HREF="#> <pg> put">put</A> them back.
<HR WIDTH="100%">
<BR><B>> &lt;mp> fsync</B>
<P>This command flushes all of the file's dirty pages to disk.&nbsp; It
is a direct call to the <A HREF="../../docs/api_c/memp_fsync.html">memp_fsync</A>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message.
<HR WIDTH="100%">
<BR><A NAME="> <mp> get"></A><B>> &lt;mp> get [-create] [-last] [-new]
[<I>pgno</I>]</B>
<P>This command gets the&nbsp; <B><I>pgno </I></B>page from the memory
pool.&nbsp; It invokes the <A HREF="../../docs/api_c/memp_fget.html">memp_fget</A>
function and possibly the <A HREF="../../docs/api_c/memp_fset.html">memp_fset</A>
function if any options are chosen to set the page characteristics.&nbsp;
After it successfully gets a handle to a page,&nbsp; we bind it to and
return a new Tcl command of the form <B><I>$env.mpN.pX</I></B>, where X
is an integer starting at&nbsp; 0 (e.g. <B>$env.mp0.p0, $env.mp1.p0, </B>etc).&nbsp;
We use the <I>Tcl_CreateObjCommand()</I> to create the top level page functions.&nbsp;
It is through this handle that the user can manipulate the page.&nbsp;
Internally, the handle we get back from DB will be stored as the <I>ClientData</I>
portion of the new command set.&nbsp; We need to store this handle in&nbsp;
relation to the memory pool handle so that if the memory pool is closed,
we will <A HREF="#> <pg> put">put</A> back the pages (setting the discard
flag) and delete that set of commands.
<P>The arguments are:
<UL>
<LI>
<B>-create </B>selects the DB_MPOOL_CREATE flag&nbsp; to create the page
if it does not exist.</LI>
<LI>
<B>-last</B> selects the DB_MPOOL_LAST flag to return the last page in
the file</LI>
<LI>
<B>-new</B> selects the DB_MPOOL_NEW flag to create a new page</LI>
</UL>
<HR WIDTH="100%">
<BR><B>> &lt;pg> pgnum</B>
<P>This command returns the page number associated with this memory pool
page.&nbsp; Primarily it will be used after an <A HREF="#> <mp> get">&lt;mp>
get</A> call.
<BR>
<HR WIDTH="100%"><B>> &lt;pg> pgsize</B>
<P>This command returns the page size associated with this memory pool
page.&nbsp; Primarily it will be used after an <A HREF="#> <mp> get">&lt;mp>
get</A> call.
<BR>
<HR WIDTH="100%"><B>> &lt;pg> set [-clean] [-dirty] [-discard]</B>
<P>This command sets the characteristics of the page.&nbsp; It is a direct
call to the <A HREF="../../docs/api_c/memp_fset.html">memp_fset</A> function.&nbsp;
It returns either a 0 (for success), a DB error message or it throws a
Tcl error with a system message.&nbsp; The arguments are:
<UL>
<LI>
<B>-clean</B> selects the DB_MPOOL_CLEAN flag to indicate this is a clean
page</LI>
<LI>
<B>-dirty</B> selects the DB_MPOOL_DIRTY flag to indicate this page should
be flushed before eviction</LI>
<LI>
<B>-discard</B> selects the DB_MPOOL_DISCARD flag to indicate this page
is unimportant</LI>
</UL>
<HR WIDTH="100%">
<BR><A NAME="> <pg> put"></A><B>> &lt;pg> put [-clean] [-dirty] [-discard]</B>
<P>This command will put back the page to the memory pool.&nbsp; It is
a direct call to the <A HREF="../../docs/api_c/memp_fput.html">memp_fput</A>
function.&nbsp; It returns either a 0 (for success), a DB error message
or it throws a Tcl error with a system message. Additionally, since the
handle is no longer valid, we will call
<I>Tcl_DeleteCommand()
</I>so that
further uses of the handle will be dealt with properly by Tcl itself.&nbsp;
We must also remove the reference to this handle from the memory pool.
<P>The arguments are:
<UL>
<LI>
<B>-clean</B> selects the DB_MPOOL_CLEAN flag to indicate this is a clean
page</LI>
<LI>
<B>-dirty</B> selects the DB_MPOOL_DIRTY flag to indicate this page should
be flushed before eviction</LI>
<LI>
<B>-discard</B> selects the DB_MPOOL_DISCARD flag to indicate this page
is unimportant</LI>
</UL>
<HR WIDTH="100%">
<BR><B>> &lt;pg> init <I>val|string</I></B>
<P>This command initializes the page to the <B><I>val</I></B> given or
places the <B><I>string</I></B> given at the beginning of the page.&nbsp;
It returns a 0 for success or it throws a Tcl error with an error message.
<P>
<HR WIDTH="100%">
<BR><B>> &lt;pg> is_setto <I>val|string</I></B>
<P>This command verifies the page contains the <B><I>val</I></B> given
or checks that the <B>string</B> given is at the beginning of the page.&nbsp;
It returns a 1 if the page is correctly set to the value and a 0 otherwise.

50
tcl/docs/rep.html Normal file
View File

@@ -0,0 +1,50 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<title>Replication commands</title>
</head>
<body>
<h2>
<a NAME="Replication Commands"></a>Replication Commands</h2>
Replication commands are invoked from the environment handle, after
it has been opened with the appropriate flags defined
<a href="./env.html">here</a>.<br>
<hr WIDTH="100%">
<p><b>> &lt;env> rep_process_message <i>machid</i> <i>control</i>
<i>rec</i></b>
<p>This command processes a single incoming replication message.&nbsp; It
is a direct translation of the <a
href="../../docs/api_c/rep_process_message.html">rep_process_message</a>
function.&nbsp;
It returns either a 0 (for success), a DB error message or it throws a
Tcl error with a system message.&nbsp; The arguments are:
<ul>
<li>
<b>machid </b>is the machine ID of the machine that <i>sent</i> this
message.</li>
<li>
<b>control</b> is a binary string containing the exact contents of the
<b><i>control</i></b> argument to the <b><i>sendproc</i></b> function
that was passed this message on another site.</li>
<li>
<b>rec</b> is a binary string containing the exact contents of the
<b><i>rec</i></b> argument to the <b><i>sendproc</i></b> function
that was passed this message on another site.</li>
</ul>
<hr WIDTH="100%">
<br><b>> &lt;env> rep_elect <i>nsites</i> <i>pri</i> <i>wait</i>
<i>sleep</i></b>
<p>This command causes a replication election.&nbsp; It is a direct translation
of the <a href="../../docs/api_c/rep_elect.html">rep_elect</a> function.&nbsp;
Its arguments, all integers, correspond exactly to that C function's
parameters.
It will return a list containing two integers, which contain,
respectively, the integer values returned in the C function's
<i><b>midp</b></i> and <i><b>selfp</b></i> parameters.
</body>
</html>

93
tcl/docs/sequence.html Normal file
View File

@@ -0,0 +1,93 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<meta http-equiv="content-type"
content="text/html; charset=ISO-8859-1">
<title>Sequence Commands</title>
</head>
<body>
<h2><a name="Database Commands"></a>Sequence Commands</h2>
<b>&gt; berkdb sequence [-auto_commit] [-txn txnid] [-create] </b><br>
<div style="margin-left: 40px;">&nbsp;Implements <a
href="file:///home/ubell/db.new/docs/seq/seq_open.html">DBENV-&gt;sequence</a>
function. The above options have the usual meanings.<br>
</div>
<span style="font-weight: bold;">[-cachesize]</span><br>
<div style="margin-left: 40px;">Set the size of the cache in this
handle.<br>
</div>
<span style="font-weight: bold;">[-inc]<br>
</span>
<div style="margin-left: 40px;">Sequence increments..<br>
</div>
<span style="font-weight: bold;">[-dec]<br>
</span>
<div style="margin-left: 40px;">Sequence decrements.<br>
</div>
<span style="font-weight: bold;">[-init integer]<br>
</span>
<div style="margin-left: 40px;">Set the initial value for sequence.<br>
</div>
<span style="font-weight: bold;">[-max integer]</span><br>
<div style="margin-left: 40px;">Set the maximum value for the sequence.<br>
</div>
<span style="font-weight: bold;">[-max integer]<br>
</span>
<div style="margin-left: 40px;">Set the minimum value for the sequence.<br>
</div>
<span style="font-weight: bold;">[-wrap]</span><br>
<div style="margin-left: 40px;">Wrap around at max or min.<br>
</div>
<span style="font-weight: bold;"><span style="font-style: italic;">db</span>
key<br>
</span>
<div style="margin-left: 40px;">Database handle and key of sequence.<br>
</div>
<hr width="100%"><span style="font-style: italic;"><span
style="font-weight: bold;">&gt; seq </span></span><span
style="font-weight: bold;">get [-txn <span style="font-style: italic;">txn</span>]
[-auto_commit] [-nosync] delta<br>
</span>
<div style="margin-left: 40px;">Get the nexted sequence value and
increment the sequence by <span style="font-weight: bold;">delta</span>.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq </span>close</span><br>
<div style="margin-left: 40px;">Close the sequence<br>
</div>
<br>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq</span> remove [-auto_commit] [-nosync]
[-txn] <br>
</span>
<div style="margin-left: 40px;">Remove the sequence.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq </span>get_cachesize<br>
</span>
<div style="margin-left: 40px;">Return the size of the cache.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq </span>get_db<br>
</span>
<div style="margin-left: 40px;">Return the underlying db handle.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq </span>get_flags</span><br>
<div style="margin-left: 40px;">Return the flags set on create.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq</span> get_range<br>
</span>
<div style="margin-left: 40px;">Return the min and max set at create.<br>
</div>
<hr width="100%"><span style="font-weight: bold;">&gt; <span
style="font-style: italic;">seq </span>stat<br>
</span>
<div style="margin-left: 40px;">Implements the <a
href="../../docs/seq/seq_stat.html">SEQUENCE-&gt;stat</a> function.<br>
</div>
<hr width="100%">
</body>
</html>

103
tcl/docs/test.html Normal file
View File

@@ -0,0 +1,103 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 2.2.8-19990120-SNAP i386) [Netscape]">
</HEAD>
<BODY>
<H2>
<A NAME="Debugging"></A>Debugging and Testing</H2>
We have imported the debugging system from the old test suite into the
new interface to aid in debugging problems.&nbsp; There are several variables
that are available both in gdb as globals to the C code, and variables
in Tcl that the user can set.&nbsp; These variables are linked together
so that changes in one venue are reflected in the other.&nbsp; The names
of the variables have been modified a bit to reduce the likelihood
<BR>of namespace trampling.&nbsp; We have added a double underscore to
all the names.
<P>The variables are all initialized to zero (0) thus resulting in debugging
being turned off.&nbsp; The purpose of the debugging, fundamentally, is
to allow the user to set a breakpoint prior to making a DB call.&nbsp;
This breakpoint is set in the <I>__db_loadme() </I>function.&nbsp; The
user may selectively turn on various debugging areas each controlled by
a separate variable (note they all have two (2) underscores prepended to
the name):
<UL>
<LI>
<B>__debug_on</B> - Turns on the debugging system.&nbsp; This must be on
for any debugging to occur</LI>
<LI>
<B>__debug_print - </B>Turns on printing a debug count statement on each
call</LI>
<LI>
<B>__debug_test -</B> Hits the breakpoint in <I>__db_loadme</I> on the
specific iteration</LI>
<LI>
<B>__debug_stop </B>- Hits the breakpoint in <I>__db_loadme</I> on every
(or the next) iteration</LI>
</UL>
<B>Note to developers:</B>&nbsp; Anyone extending this interface must place
a call to <B>_debug_check()</B> (no arguments) before every call into the
DB library.
<P>There is also a command available that will force a call to the _debug_check
function.
<P><B>> berkdb debug_check</B>
<P>
<HR WIDTH="100%">
<BR>For testing purposes we have added several hooks into the DB library
and a small interface into the environment and/or database commands to
manipulate the hooks.&nbsp; This command interface and the hooks and everything
that goes with it is only enabled when the test option is configured into
DB.
<P><B>> &lt;env> test copy <I>location</I></B>
<BR><B>> &lt;db> test copy <I>location</I></B>
<BR><B>> &lt;env> test abort <I>location</I></B>
<BR><B>> &lt;db> test abort <I>location</I></B>
<P>In order to test recovery we need to be able to abort the creation or
deletion process at various points.&nbsp; Also we want to invoke a copy
function to copy the database file(s)&nbsp; at various points as well so
that we can obtain before/after snapshots of the databases.&nbsp; The interface
provides the test command to specify a <B><I>location</I></B> where we
wish to invoke a <B>copy</B> or an <B>abort</B>.&nbsp; The command is available
from either the environment or the database for convenience.&nbsp; The
<B><I>location</I></B>
can be one of the following:
<UL>
<LI>
<B>none -</B> Clears the location</LI>
<LI>
<B>preopen -</B> Sets the location prior to the __os_open call in the creation
process</LI>
<LI>
<B>postopen</B> - Sets the location to immediately following the __os_open
call in creation</LI>
<LI>
<B>postlogmeta</B> - Sets the location to immediately following the __db_log_page
call to log the meta data in creation.&nbsp; Only valid for Btree.</LI>
<LI>
<B>postlog</B> - Sets the location to immediately following the last (or
only) __db_log_page call in creation.</LI>
<LI>
<B>postsync</B> - Sets the location to immediately following the sync of
the log page in creation.</LI>
<LI>
<B>prerename</B> - Sets the location prior to the __os_rename call in the
deletion process.</LI>
<LI>
<B>postrename</B> - Sets the location to immediately following the __os_rename
call in deletion</LI>
</UL>
</BODY>
</HTML>

69
tcl/docs/txn.html Normal file
View File

@@ -0,0 +1,69 @@
<!--Copyright 1999,2008 Oracle. All rights reserved.-->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta name="GENERATOR" content="Mozilla/4.75 [en] (X11; U; Linux 2.2.16-22 i686) [Netscape]">
</head>
<body>
<h2>
<a NAME="Transaction Commands"></a>Transaction Commands</h2>
Transactions are used in a manner similar to the other subsystems.&nbsp;
We create a handle to the transaction and&nbsp; then use it for a variety
of operations.&nbsp; Some of the transaction commands use the environment
instead.&nbsp; Those are presented first.&nbsp; The transaction command
handle returned is the handle used by the various commands that can be
transaction protected, such as <a href="../../docs/api_tcl/db_cursor.html">cursors</a>.
<br>
<hr WIDTH="100%">
<p><b>> &lt;env> txn_checkpoint [-kbyte <i>kb</i>] [-min <i>min</i>]</b>
<p>This command causes a checkpoint of the transaction region.&nbsp; It
is a direct translation of the <a href="../../docs/api_c/txn_checkpoint.html">txn_checkpoint
</a>function.&nbsp;
It returns either a 0 (for success), a DB error message or it throws a
Tcl error with a system message.&nbsp; The arguments are:
<ul>
<li>
<b>-force</b>causes the checkpoint to occur regardless of inactivity
<li>
<b>-kbyte</b>causes the checkpoint to occur only if <b><i>kb</i></b> kilobytes
of log data has been written since the last checkpoint
<li>
<b>-min</b> causes the checkpoint to occur only if <b><i>min</i></b> minutes
have passed since the last checkpoint
</ul>
<hr WIDTH="100%">
<br><b>> &lt;env> txn_stat</b>
<p>This command returns transaction statistics.&nbsp; It is a direct translation
of the <a href="../../docs/api_c/txn_stat.html">txn_stat</a> function.&nbsp;
It will return a list of name/value pairs that correspond to the DB_TXN_STAT
structure.
<hr WIDTH="100%">
<br><b>> &lt;env> txn_id_set&nbsp;</b><i> current max</i>
<p>This is a diagnosic command that sets the next transaction id to be
allocated and the maximum transaction
<br>id, which is the point at which the relcaimation algorthm is triggered.
<hr WIDTH="100%">
<br><b>>&nbsp; &lt;txn> id</b>
<p>This command returns the transaction id.&nbsp; It is a direct call to
the <a href="../../docs/api_c/txn_id.html">txn_id</a> function.&nbsp; The
typical use of this identifier is as the <b><i>locker</i></b> value for
the <a href="lock.html">lock_get</a> and <a href="lock.html">lock_vec</a>
calls.
<hr WIDTH="100%">
<br><b>> &lt;txn> prepare</b>
<p>This command initiates a two-phase commit.&nbsp; It is a direct call
to the <a href="../../docs/api_c/txn_prepare.html">txn_prepare</a> function.&nbsp;
It returns either a 0 (for success), a DB error message or it throws a
Tcl error with a system message.
<hr WIDTH="100%"><a NAME="> <env> lock_vec"></a><b>> &lt;env> txn_timeout
<i>timeout</i></b>
<p>This command sets thetransaction timeout for transactions started in
the future in this environment.&nbsp; The timeout is in micorseconds.
<br>&nbsp;
<br>&nbsp;
</body>
</html>

738
tcl/tcl_compat.c Normal file
View File

@@ -0,0 +1,738 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_compat.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#ifdef CONFIG_TEST
#define DB_DBM_HSEARCH 1
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
/*
* bdb_HCommand --
* Implements h* functions.
*
* PUBLIC: int bdb_HCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
*/
int
bdb_HCommand(interp, objc, objv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *hcmds[] = {
"hcreate",
"hdestroy",
"hsearch",
NULL
};
enum hcmds {
HHCREATE,
HHDESTROY,
HHSEARCH
};
static const char *srchacts[] = {
"enter",
"find",
NULL
};
enum srchacts {
ACT_ENTER,
ACT_FIND
};
ENTRY item, *hres;
ACTION action;
int actindex, cmdindex, nelem, result, ret;
Tcl_Obj *res;
result = TCL_OK;
/*
* Get the command name index from the object based on the cmds
* defined above. This SHOULD NOT fail because we already checked
* in the 'berkdb' command.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], hcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum hcmds)cmdindex) {
case HHCREATE:
/*
* Must be 1 arg, nelem. Error if not.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "nelem");
return (TCL_ERROR);
}
result = Tcl_GetIntFromObj(interp, objv[2], &nelem);
if (result == TCL_OK) {
_debug_check();
ret = hcreate((size_t)nelem) == 0 ? 1: 0;
(void)_ReturnSetup(
interp, ret, DB_RETOK_STD(ret), "hcreate");
}
break;
case HHSEARCH:
/*
* 3 args for this. Error if different.
*/
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "key data action");
return (TCL_ERROR);
}
item.key = Tcl_GetStringFromObj(objv[2], NULL);
item.data = Tcl_GetStringFromObj(objv[3], NULL);
if (Tcl_GetIndexFromObj(interp, objv[4], srchacts,
"action", TCL_EXACT, &actindex) != TCL_OK)
return (IS_HELP(objv[4]));
switch ((enum srchacts)actindex) {
case ACT_ENTER:
action = ENTER;
break;
default:
case ACT_FIND:
action = FIND;
break;
}
_debug_check();
hres = hsearch(item, action);
if (hres == NULL)
Tcl_SetResult(interp, "-1", TCL_STATIC);
else if (action == FIND)
Tcl_SetResult(interp, (char *)hres->data, TCL_STATIC);
else
/* action is ENTER */
Tcl_SetResult(interp, "0", TCL_STATIC);
break;
case HHDESTROY:
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
hdestroy();
res = Tcl_NewIntObj(0);
break;
}
/*
* Only set result if we have a res. Otherwise, lower
* functions have already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}
/*
*
* bdb_NdbmOpen --
* Opens an ndbm database.
*
* PUBLIC: #if DB_DBM_HSEARCH != 0
* PUBLIC: int bdb_NdbmOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBM **));
* PUBLIC: #endif
*/
int
bdb_NdbmOpen(interp, objc, objv, dbpp)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DBM **dbpp; /* Dbm pointer */
{
static const char *ndbopen[] = {
"-create",
"-mode",
"-rdonly",
"-truncate",
"--",
NULL
};
enum ndbopen {
NDB_CREATE,
NDB_MODE,
NDB_RDONLY,
NDB_TRUNC,
NDB_ENDARG
};
int endarg, i, mode, open_flags, optindex, read_only, result, ret;
char *arg, *db;
result = TCL_OK;
endarg = mode = open_flags = read_only = 0;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?args?");
return (TCL_ERROR);
}
/*
* Get the option name index from the object based on the args
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i], ndbopen, "option",
TCL_EXACT, &optindex) != TCL_OK) {
arg = Tcl_GetStringFromObj(objv[i], NULL);
if (arg[0] == '-') {
result = IS_HELP(objv[i]);
goto error;
} else
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum ndbopen)optindex) {
case NDB_CREATE:
open_flags |= O_CREAT;
break;
case NDB_RDONLY:
read_only = 1;
break;
case NDB_TRUNC:
open_flags |= O_TRUNC;
break;
case NDB_MODE:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-mode mode?");
result = TCL_ERROR;
break;
}
/*
* Don't need to check result here because
* if TCL_ERROR, the error message is already
* set up, and we'll bail out below. If ok,
* the mode is set and we go on.
*/
result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
break;
case NDB_ENDARG:
endarg = 1;
break;
}
/*
* If, at any time, parsing the args we get an error,
* bail out and return.
*/
if (result != TCL_OK)
goto error;
if (endarg)
break;
}
if (result != TCL_OK)
goto error;
/*
* Any args we have left, (better be 0, or 1 left) is a
* file name. If we have 0, then an in-memory db. If
* there is 1, a db name.
*/
db = NULL;
if (i != objc && i != objc - 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
result = TCL_ERROR;
goto error;
}
if (i != objc)
db = Tcl_GetStringFromObj(objv[objc - 1], NULL);
/*
* When we get here, we have already parsed all of our args
* and made all our calls to set up the database. Everything
* is okay so far, no errors, if we get here.
*
* Now open the database.
*/
if (read_only)
open_flags |= O_RDONLY;
else
open_flags |= O_RDWR;
_debug_check();
if ((*dbpp = dbm_open(db, open_flags, mode)) == NULL) {
ret = Tcl_GetErrno();
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"db open");
goto error;
}
return (TCL_OK);
error:
*dbpp = NULL;
return (result);
}
/*
* bdb_DbmCommand --
* Implements "dbm" commands.
*
* PUBLIC: #if DB_DBM_HSEARCH != 0
* PUBLIC: int bdb_DbmCommand
* PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST*, int, DBM *));
* PUBLIC: #endif
*/
int
bdb_DbmCommand(interp, objc, objv, flag, dbm)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
int flag; /* Which db interface */
DBM *dbm; /* DBM pointer */
{
static const char *dbmcmds[] = {
"dbmclose",
"dbminit",
"delete",
"fetch",
"firstkey",
"nextkey",
"store",
NULL
};
enum dbmcmds {
DBMCLOSE,
DBMINIT,
DBMDELETE,
DBMFETCH,
DBMFIRST,
DBMNEXT,
DBMSTORE
};
static const char *stflag[] = {
"insert", "replace",
NULL
};
enum stflag {
STINSERT, STREPLACE
};
datum key, data;
void *dtmp, *ktmp;
u_int32_t size;
int cmdindex, freedata, freekey, stindex, result, ret;
char *name, *t;
result = TCL_OK;
freekey = freedata = 0;
dtmp = ktmp = NULL;
/*
* Get the command name index from the object based on the cmds
* defined above. This SHOULD NOT fail because we already checked
* in the 'berkdb' command.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], dbmcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
switch ((enum dbmcmds)cmdindex) {
case DBMCLOSE:
/*
* No arg for this. Error if different.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
if (flag == DBTCL_DBM)
ret = dbmclose();
else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
return (TCL_ERROR);
}
(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "dbmclose");
break;
case DBMINIT:
/*
* Must be 1 arg - file.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return (TCL_ERROR);
}
name = Tcl_GetStringFromObj(objv[2], NULL);
if (flag == DBTCL_DBM)
ret = dbminit(name);
else {
Tcl_SetResult(interp, "Bad interface flag for command",
TCL_STATIC);
return (TCL_ERROR);
}
(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "dbminit");
break;
case DBMFETCH:
/*
* 1 arg for this. Error if different.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return (TCL_ERROR);
}
if ((ret = _CopyObjBytes(
interp, objv[2], &ktmp, &size, &freekey)) != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "dbm fetch");
goto out;
}
key.dsize = (int)size;
key.dptr = (char *)ktmp;
_debug_check();
if (flag == DBTCL_DBM)
data = fetch(key);
else if (flag == DBTCL_NDBM)
data = dbm_fetch(dbm, key);
else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
result = TCL_ERROR;
goto out;
}
if (data.dptr == NULL ||
(ret = __os_malloc(NULL, (size_t)data.dsize + 1, &t)) != 0)
Tcl_SetResult(interp, "-1", TCL_STATIC);
else {
memcpy(t, data.dptr, (size_t)data.dsize);
t[data.dsize] = '\0';
Tcl_SetResult(interp, t, TCL_VOLATILE);
__os_free(NULL, t);
}
break;
case DBMSTORE:
/*
* 2 args for this. Error if different.
*/
if (objc != 4 && flag == DBTCL_DBM) {
Tcl_WrongNumArgs(interp, 2, objv, "key data");
return (TCL_ERROR);
}
if (objc != 5 && flag == DBTCL_NDBM) {
Tcl_WrongNumArgs(interp, 2, objv, "key data action");
return (TCL_ERROR);
}
if ((ret = _CopyObjBytes(
interp, objv[2], &ktmp, &size, &freekey)) != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "dbm fetch");
goto out;
}
key.dsize = (int)size;
key.dptr = (char *)ktmp;
if ((ret = _CopyObjBytes(
interp, objv[3], &dtmp, &size, &freedata)) != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "dbm fetch");
goto out;
}
data.dsize = (int)size;
data.dptr = (char *)dtmp;
_debug_check();
if (flag == DBTCL_DBM)
ret = store(key, data);
else if (flag == DBTCL_NDBM) {
if (Tcl_GetIndexFromObj(interp, objv[4], stflag,
"flag", TCL_EXACT, &stindex) != TCL_OK)
return (IS_HELP(objv[4]));
switch ((enum stflag)stindex) {
case STINSERT:
flag = DBM_INSERT;
break;
case STREPLACE:
flag = DBM_REPLACE;
break;
}
ret = dbm_store(dbm, key, data, flag);
} else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
return (TCL_ERROR);
}
(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "store");
break;
case DBMDELETE:
/*
* 1 arg for this. Error if different.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "key");
return (TCL_ERROR);
}
if ((ret = _CopyObjBytes(
interp, objv[2], &ktmp, &size, &freekey)) != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "dbm fetch");
goto out;
}
key.dsize = (int)size;
key.dptr = (char *)ktmp;
_debug_check();
if (flag == DBTCL_DBM)
ret = delete(key);
else if (flag == DBTCL_NDBM)
ret = dbm_delete(dbm, key);
else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
return (TCL_ERROR);
}
(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "delete");
break;
case DBMFIRST:
/*
* No arg for this. Error if different.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
if (flag == DBTCL_DBM)
key = firstkey();
else if (flag == DBTCL_NDBM)
key = dbm_firstkey(dbm);
else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
return (TCL_ERROR);
}
if (key.dptr == NULL ||
(ret = __os_malloc(NULL, (size_t)key.dsize + 1, &t)) != 0)
Tcl_SetResult(interp, "-1", TCL_STATIC);
else {
memcpy(t, key.dptr, (size_t)key.dsize);
t[key.dsize] = '\0';
Tcl_SetResult(interp, t, TCL_VOLATILE);
__os_free(NULL, t);
}
break;
case DBMNEXT:
/*
* 0 or 1 arg for this. Error if different.
*/
_debug_check();
if (flag == DBTCL_DBM) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
if ((ret = _CopyObjBytes(
interp, objv[2], &ktmp, &size, &freekey)) != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "dbm fetch");
goto out;
}
key.dsize = (int)size;
key.dptr = (char *)ktmp;
data = nextkey(key);
} else if (flag == DBTCL_NDBM) {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
data = dbm_nextkey(dbm);
} else {
Tcl_SetResult(interp,
"Bad interface flag for command", TCL_STATIC);
return (TCL_ERROR);
}
if (data.dptr == NULL ||
(ret = __os_malloc(NULL, (size_t)data.dsize + 1, &t)) != 0)
Tcl_SetResult(interp, "-1", TCL_STATIC);
else {
memcpy(t, data.dptr, (size_t)data.dsize);
t[data.dsize] = '\0';
Tcl_SetResult(interp, t, TCL_VOLATILE);
__os_free(NULL, t);
}
break;
}
out: if (dtmp != NULL && freedata)
__os_free(NULL, dtmp);
if (ktmp != NULL && freekey)
__os_free(NULL, ktmp);
return (result);
}
/*
* ndbm_Cmd --
* Implements the "ndbm" widget.
*
* PUBLIC: int ndbm_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
*/
int
ndbm_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* DB handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *ndbcmds[] = {
"clearerr",
"close",
"delete",
"dirfno",
"error",
"fetch",
"firstkey",
"nextkey",
"pagfno",
"rdonly",
"store",
NULL
};
enum ndbcmds {
NDBCLRERR,
NDBCLOSE,
NDBDELETE,
NDBDIRFNO,
NDBERR,
NDBFETCH,
NDBFIRST,
NDBNEXT,
NDBPAGFNO,
NDBRDONLY,
NDBSTORE
};
DBM *dbp;
DBTCL_INFO *dbip;
Tcl_Obj *res;
int cmdindex, result, ret;
Tcl_ResetResult(interp);
dbp = (DBM *)clientData;
dbip = _PtrToInfo((void *)dbp);
result = TCL_OK;
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
return (TCL_ERROR);
}
if (dbp == NULL) {
Tcl_SetResult(interp, "NULL db pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (dbip == NULL) {
Tcl_SetResult(interp, "NULL db info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], ndbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum ndbcmds)cmdindex) {
case NDBCLOSE:
_debug_check();
dbm_close(dbp);
(void)Tcl_DeleteCommand(interp, dbip->i_name);
_DeleteInfo(dbip);
res = Tcl_NewIntObj(0);
break;
case NDBDELETE:
case NDBFETCH:
case NDBFIRST:
case NDBNEXT:
case NDBSTORE:
result = bdb_DbmCommand(interp, objc, objv, DBTCL_NDBM, dbp);
break;
case NDBCLRERR:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbm_clearerr(dbp);
if (ret)
(void)_ReturnSetup(
interp, ret, DB_RETOK_STD(ret), "clearerr");
else
res = Tcl_NewIntObj(ret);
break;
case NDBDIRFNO:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbm_dirfno(dbp);
res = Tcl_NewIntObj(ret);
break;
case NDBPAGFNO:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbm_pagfno(dbp);
res = Tcl_NewIntObj(ret);
break;
case NDBERR:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbm_error(dbp);
Tcl_SetErrno(ret);
Tcl_SetResult(interp,
(char *)Tcl_PosixError(interp), TCL_STATIC);
break;
case NDBRDONLY:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbm_rdonly(dbp);
if (ret)
(void)_ReturnSetup(
interp, ret, DB_RETOK_STD(ret), "rdonly");
else
res = Tcl_NewIntObj(ret);
break;
}
/*
* Only set result if we have a res. Otherwise, lower functions have
* already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}
#endif /* CONFIG_TEST */

3219
tcl/tcl_db.c Normal file
View File

File diff suppressed because it is too large Load Diff

3892
tcl/tcl_db_pkg.c Normal file
View File

File diff suppressed because it is too large Load Diff

973
tcl/tcl_dbcursor.c Normal file
View File

@@ -0,0 +1,973 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_dbcursor.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int tcl_DbcDup __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *));
static int tcl_DbcGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *, int));
static int tcl_DbcPut __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *));
/*
* PUBLIC: int dbc_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
*
* dbc_cmd --
* Implements the cursor command.
*/
int
dbc_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Cursor handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *dbccmds[] = {
#ifdef CONFIG_TEST
"pget",
#endif
"close",
"del",
"dup",
"get",
"put",
NULL
};
enum dbccmds {
#ifdef CONFIG_TEST
DBCPGET,
#endif
DBCCLOSE,
DBCDELETE,
DBCDUP,
DBCGET,
DBCPUT
};
DBC *dbc;
DBTCL_INFO *dbip;
int cmdindex, result, ret;
Tcl_ResetResult(interp);
dbc = (DBC *)clientData;
dbip = _PtrToInfo((void *)dbc);
result = TCL_OK;
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
return (TCL_ERROR);
}
if (dbc == NULL) {
Tcl_SetResult(interp, "NULL dbc pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (dbip == NULL) {
Tcl_SetResult(interp, "NULL dbc info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the berkdbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], dbccmds, "command",
TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
switch ((enum dbccmds)cmdindex) {
#ifdef CONFIG_TEST
case DBCPGET:
result = tcl_DbcGet(interp, objc, objv, dbc, 1);
break;
#endif
case DBCCLOSE:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbc->close(dbc);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"dbc close");
if (result == TCL_OK) {
(void)Tcl_DeleteCommand(interp, dbip->i_name);
_DeleteInfo(dbip);
}
break;
case DBCDELETE:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbc->del(dbc, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_DBCDEL(ret),
"dbc delete");
break;
case DBCDUP:
result = tcl_DbcDup(interp, objc, objv, dbc);
break;
case DBCGET:
result = tcl_DbcGet(interp, objc, objv, dbc, 0);
break;
case DBCPUT:
result = tcl_DbcPut(interp, objc, objv, dbc);
break;
}
return (result);
}
/*
* tcl_DbcPut --
*/
static int
tcl_DbcPut(interp, objc, objv, dbc)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DBC *dbc; /* Cursor pointer */
{
static const char *dbcutopts[] = {
#ifdef CONFIG_TEST
"-nodupdata",
#endif
"-after",
"-before",
"-current",
"-keyfirst",
"-keylast",
"-partial",
NULL
};
enum dbcutopts {
#ifdef CONFIG_TEST
DBCPUT_NODUPDATA,
#endif
DBCPUT_AFTER,
DBCPUT_BEFORE,
DBCPUT_CURRENT,
DBCPUT_KEYFIRST,
DBCPUT_KEYLAST,
DBCPUT_PART
};
DB *thisdbp;
DBT key, data;
DBTCL_INFO *dbcip, *dbip;
DBTYPE type;
Tcl_Obj **elemv, *res;
void *dtmp, *ktmp;
db_recno_t recno;
u_int32_t flag;
int elemc, freekey, freedata, i, optindex, result, ret;
COMPQUIET(dtmp, NULL);
COMPQUIET(ktmp, NULL);
result = TCL_OK;
flag = 0;
freekey = freedata = 0;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? ?key?");
return (TCL_ERROR);
}
memset(&key, 0, sizeof(key));
memset(&data, 0, sizeof(data));
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
while (i < (objc - 1)) {
if (Tcl_GetIndexFromObj(interp, objv[i], dbcutopts, "option",
TCL_EXACT, &optindex) != TCL_OK) {
/*
* Reset the result so we don't get
* an errant error message if there is another error.
*/
if (IS_HELP(objv[i]) == TCL_OK) {
result = TCL_OK;
goto out;
}
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum dbcutopts)optindex) {
#ifdef CONFIG_TEST
case DBCPUT_NODUPDATA:
FLAG_CHECK(flag);
flag = DB_NODUPDATA;
break;
#endif
case DBCPUT_AFTER:
FLAG_CHECK(flag);
flag = DB_AFTER;
break;
case DBCPUT_BEFORE:
FLAG_CHECK(flag);
flag = DB_BEFORE;
break;
case DBCPUT_CURRENT:
FLAG_CHECK(flag);
flag = DB_CURRENT;
break;
case DBCPUT_KEYFIRST:
FLAG_CHECK(flag);
flag = DB_KEYFIRST;
break;
case DBCPUT_KEYLAST:
FLAG_CHECK(flag);
flag = DB_KEYLAST;
break;
case DBCPUT_PART:
if (i > (objc - 2)) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-partial {offset length}?");
result = TCL_ERROR;
break;
}
/*
* Get sublist as {offset length}
*/
result = Tcl_ListObjGetElements(interp, objv[i++],
&elemc, &elemv);
if (elemc != 2) {
Tcl_SetResult(interp,
"List must be {offset length}", TCL_STATIC);
result = TCL_ERROR;
break;
}
data.flags |= DB_DBT_PARTIAL;
result = _GetUInt32(interp, elemv[0], &data.doff);
if (result != TCL_OK)
break;
result = _GetUInt32(interp, elemv[1], &data.dlen);
/*
* NOTE: We don't check result here because all we'd
* do is break anyway, and we are doing that. If you
* add code here, you WILL need to add the check
* for result. (See the check for save.doff, a few
* lines above and copy that.)
*/
}
if (result != TCL_OK)
break;
}
if (result != TCL_OK)
goto out;
/*
* We need to determine if we are a recno database or not. If we are,
* then key.data is a recno, not a string.
*/
dbcip = _PtrToInfo(dbc);
if (dbcip == NULL)
type = DB_UNKNOWN;
else {
dbip = dbcip->i_parent;
if (dbip == NULL) {
Tcl_SetResult(interp, "Cursor without parent database",
TCL_STATIC);
result = TCL_ERROR;
return (result);
}
thisdbp = dbip->i_dbp;
(void)thisdbp->get_type(thisdbp, &type);
}
/*
* When we get here, we better have:
* 1 arg if -after, -before or -current
* 2 args in all other cases
*/
if (flag == DB_AFTER || flag == DB_BEFORE || flag == DB_CURRENT) {
if (i != (objc - 1)) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-args? data");
result = TCL_ERROR;
goto out;
}
/*
* We want to get the key back, so we need to set
* up the location to get it back in.
*/
if (type == DB_RECNO || type == DB_QUEUE) {
recno = 0;
key.data = &recno;
key.size = sizeof(db_recno_t);
}
} else {
if (i != (objc - 2)) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-args? key data");
result = TCL_ERROR;
goto out;
}
if (type == DB_RECNO || type == DB_QUEUE) {
result = _GetUInt32(interp, objv[objc-2], &recno);
if (result == TCL_OK) {
key.data = &recno;
key.size = sizeof(db_recno_t);
} else
return (result);
} else {
ret = _CopyObjBytes(interp, objv[objc-2], &ktmp,
&key.size, &freekey);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_DBCPUT(ret), "dbc put");
return (result);
}
key.data = ktmp;
}
}
ret = _CopyObjBytes(interp, objv[objc-1], &dtmp,
&data.size, &freedata);
data.data = dtmp;
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_DBCPUT(ret), "dbc put");
goto out;
}
_debug_check();
ret = dbc->put(dbc, &key, &data, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_DBCPUT(ret),
"dbc put");
if (ret == 0 &&
(flag == DB_AFTER || flag == DB_BEFORE) && type == DB_RECNO) {
res = Tcl_NewWideIntObj((Tcl_WideInt)*(db_recno_t *)key.data);
Tcl_SetObjResult(interp, res);
}
out:
if (freedata)
__os_free(NULL, dtmp);
if (freekey)
__os_free(NULL, ktmp);
return (result);
}
/*
* tcl_dbc_get --
*/
static int
tcl_DbcGet(interp, objc, objv, dbc, ispget)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DBC *dbc; /* Cursor pointer */
int ispget; /* 1 for pget, 0 for get */
{
static const char *dbcgetopts[] = {
#ifdef CONFIG_TEST
"-data_buf_size",
"-get_both_range",
"-key_buf_size",
"-multi",
"-multi_key",
"-nolease",
"-read_committed",
"-read_uncommitted",
#endif
"-current",
"-first",
"-get_both",
"-get_recno",
"-join_item",
"-last",
"-next",
"-nextdup",
"-nextnodup",
"-partial",
"-prev",
"-prevdup",
"-prevnodup",
"-rmw",
"-set",
"-set_range",
"-set_recno",
NULL
};
enum dbcgetopts {
#ifdef CONFIG_TEST
DBCGET_DATA_BUF_SIZE,
DBCGET_BOTH_RANGE,
DBCGET_KEY_BUF_SIZE,
DBCGET_MULTI,
DBCGET_MULTI_KEY,
DBCGET_NOLEASE,
DBCGET_READ_COMMITTED,
DBCGET_READ_UNCOMMITTED,
#endif
DBCGET_CURRENT,
DBCGET_FIRST,
DBCGET_BOTH,
DBCGET_RECNO,
DBCGET_JOIN,
DBCGET_LAST,
DBCGET_NEXT,
DBCGET_NEXTDUP,
DBCGET_NEXTNODUP,
DBCGET_PART,
DBCGET_PREV,
DBCGET_PREVDUP,
DBCGET_PREVNODUP,
DBCGET_RMW,
DBCGET_SET,
DBCGET_SETRANGE,
DBCGET_SETRECNO
};
DB *thisdbp;
DBT key, data, pdata;
DBTCL_INFO *dbcip, *dbip;
DBTYPE ptype, type;
Tcl_Obj **elemv, *myobj, *retlist;
void *dtmp, *ktmp;
db_recno_t precno, recno;
u_int32_t flag, op;
int elemc, freekey, freedata, i, optindex, result, ret;
#ifdef CONFIG_TEST
int data_buf_size, key_buf_size;
data_buf_size = key_buf_size = 0;
#endif
COMPQUIET(dtmp, NULL);
COMPQUIET(ktmp, NULL);
result = TCL_OK;
flag = 0;
freekey = freedata = 0;
memset(&key, 0, sizeof(key));
memset(&data, 0, sizeof(data));
memset(&pdata, 0, sizeof(DBT));
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? ?key?");
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i], dbcgetopts,
"option", TCL_EXACT, &optindex) != TCL_OK) {
/*
* Reset the result so we don't get
* an errant error message if there is another error.
*/
if (IS_HELP(objv[i]) == TCL_OK) {
result = TCL_OK;
goto out;
}
Tcl_ResetResult(interp);
break;
}
i++;
#define FLAG_CHECK2_STDARG \
(DB_RMW | DB_MULTIPLE | DB_MULTIPLE_KEY | DB_IGNORE_LEASE | \
DB_READ_UNCOMMITTED)
switch ((enum dbcgetopts)optindex) {
#ifdef CONFIG_TEST
case DBCGET_DATA_BUF_SIZE:
result =
Tcl_GetIntFromObj(interp, objv[i], &data_buf_size);
if (result != TCL_OK)
goto out;
i++;
break;
case DBCGET_BOTH_RANGE:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_GET_BOTH_RANGE;
break;
case DBCGET_KEY_BUF_SIZE:
result =
Tcl_GetIntFromObj(interp, objv[i], &key_buf_size);
if (result != TCL_OK)
goto out;
i++;
break;
case DBCGET_MULTI:
flag |= DB_MULTIPLE;
result =
Tcl_GetIntFromObj(interp, objv[i], &data_buf_size);
if (result != TCL_OK)
goto out;
i++;
break;
case DBCGET_MULTI_KEY:
flag |= DB_MULTIPLE_KEY;
result =
Tcl_GetIntFromObj(interp, objv[i], &data_buf_size);
if (result != TCL_OK)
goto out;
i++;
break;
case DBCGET_NOLEASE:
flag |= DB_IGNORE_LEASE;
break;
case DBCGET_READ_COMMITTED:
flag |= DB_READ_COMMITTED;
break;
case DBCGET_READ_UNCOMMITTED:
flag |= DB_READ_UNCOMMITTED;
break;
#endif
case DBCGET_RMW:
flag |= DB_RMW;
break;
case DBCGET_CURRENT:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_CURRENT;
break;
case DBCGET_FIRST:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_FIRST;
break;
case DBCGET_LAST:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_LAST;
break;
case DBCGET_NEXT:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_NEXT;
break;
case DBCGET_PREV:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_PREV;
break;
case DBCGET_PREVDUP:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_PREV_DUP;
break;
case DBCGET_PREVNODUP:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_PREV_NODUP;
break;
case DBCGET_NEXTNODUP:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_NEXT_NODUP;
break;
case DBCGET_NEXTDUP:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_NEXT_DUP;
break;
case DBCGET_BOTH:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_GET_BOTH;
break;
case DBCGET_RECNO:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_GET_RECNO;
break;
case DBCGET_JOIN:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_JOIN_ITEM;
break;
case DBCGET_SET:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_SET;
break;
case DBCGET_SETRANGE:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_SET_RANGE;
break;
case DBCGET_SETRECNO:
FLAG_CHECK2(flag, FLAG_CHECK2_STDARG);
flag |= DB_SET_RECNO;
break;
case DBCGET_PART:
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-partial {offset length}?");
result = TCL_ERROR;
break;
}
/*
* Get sublist as {offset length}
*/
result = Tcl_ListObjGetElements(interp, objv[i++],
&elemc, &elemv);
if (elemc != 2) {
Tcl_SetResult(interp,
"List must be {offset length}", TCL_STATIC);
result = TCL_ERROR;
break;
}
data.flags |= DB_DBT_PARTIAL;
result = _GetUInt32(interp, elemv[0], &data.doff);
if (result != TCL_OK)
break;
result = _GetUInt32(interp, elemv[1], &data.dlen);
/*
* NOTE: We don't check result here because all we'd
* do is break anyway, and we are doing that. If you
* add code here, you WILL need to add the check
* for result. (See the check for save.doff, a few
* lines above and copy that.)
*/
break;
}
if (result != TCL_OK)
break;
}
if (result != TCL_OK)
goto out;
/*
* We need to determine if we are a recno database
* or not. If we are, then key.data is a recno, not
* a string.
*/
dbcip = _PtrToInfo(dbc);
if (dbcip == NULL) {
type = DB_UNKNOWN;
ptype = DB_UNKNOWN;
} else {
dbip = dbcip->i_parent;
if (dbip == NULL) {
Tcl_SetResult(interp, "Cursor without parent database",
TCL_STATIC);
result = TCL_ERROR;
goto out;
}
thisdbp = dbip->i_dbp;
(void)thisdbp->get_type(thisdbp, &type);
if (ispget && thisdbp->s_primary != NULL)
(void)thisdbp->
s_primary->get_type(thisdbp->s_primary, &ptype);
else
ptype = DB_UNKNOWN;
}
/*
* When we get here, we better have:
* 2 args, key and data if GET_BOTH/GET_BOTH_RANGE was specified.
* 1 arg if -set, -set_range or -set_recno
* 0 in all other cases.
*/
op = flag & DB_OPFLAGS_MASK;
switch (op) {
case DB_GET_BOTH:
#ifdef CONFIG_TEST
case DB_GET_BOTH_RANGE:
#endif
if (i != (objc - 2)) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-args? -get_both key data");
result = TCL_ERROR;
goto out;
} else {
if (type == DB_RECNO || type == DB_QUEUE) {
result = _GetUInt32(
interp, objv[objc-2], &recno);
if (result == TCL_OK) {
key.data = &recno;
key.size = sizeof(db_recno_t);
} else
goto out;
} else {
/*
* Some get calls (SET_*) can change the
* key pointers. So, we need to store
* the allocated key space in a tmp.
*/
ret = _CopyObjBytes(interp, objv[objc-2],
&ktmp, &key.size, &freekey);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_DBCGET(ret), "dbc get");
return (result);
}
key.data = ktmp;
}
if (ptype == DB_RECNO || ptype == DB_QUEUE) {
result = _GetUInt32(
interp, objv[objc-1], &precno);
if (result == TCL_OK) {
data.data = &precno;
data.size = sizeof(db_recno_t);
} else
goto out;
} else {
ret = _CopyObjBytes(interp, objv[objc-1],
&dtmp, &data.size, &freedata);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_DBCGET(ret), "dbc get");
goto out;
}
data.data = dtmp;
}
}
break;
case DB_SET:
case DB_SET_RANGE:
case DB_SET_RECNO:
if (i != (objc - 1)) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? key");
result = TCL_ERROR;
goto out;
}
#ifdef CONFIG_TEST
if (data_buf_size != 0) {
(void)__os_malloc(
NULL, (size_t)data_buf_size, &data.data);
data.ulen = (u_int32_t)data_buf_size;
data.flags |= DB_DBT_USERMEM;
} else
#endif
data.flags |= DB_DBT_MALLOC;
if (op == DB_SET_RECNO ||
type == DB_RECNO || type == DB_QUEUE) {
result = _GetUInt32(interp, objv[objc - 1], &recno);
key.data = &recno;
key.size = sizeof(db_recno_t);
} else {
/*
* Some get calls (SET_*) can change the
* key pointers. So, we need to store
* the allocated key space in a tmp.
*/
ret = _CopyObjBytes(interp, objv[objc-1],
&ktmp, &key.size, &freekey);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_DBCGET(ret), "dbc get");
return (result);
}
key.data = ktmp;
}
break;
default:
if (i != objc) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args?");
result = TCL_ERROR;
goto out;
}
#ifdef CONFIG_TEST
if (key_buf_size != 0) {
(void)__os_malloc(
NULL, (size_t)key_buf_size, &key.data);
key.ulen = (u_int32_t)key_buf_size;
key.flags |= DB_DBT_USERMEM;
} else
#endif
key.flags |= DB_DBT_MALLOC;
#ifdef CONFIG_TEST
if (data_buf_size != 0) {
(void)__os_malloc(
NULL, (size_t)data_buf_size, &data.data);
data.ulen = (u_int32_t)data_buf_size;
data.flags |= DB_DBT_USERMEM;
} else
#endif
data.flags |= DB_DBT_MALLOC;
}
_debug_check();
if (ispget) {
F_SET(&pdata, DB_DBT_MALLOC);
ret = dbc->pget(dbc, &key, &data, &pdata, flag);
} else
ret = dbc->get(dbc, &key, &data, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_DBCGET(ret), "dbc get");
if (result == TCL_ERROR)
goto out;
retlist = Tcl_NewListObj(0, NULL);
if (ret != 0)
goto out1;
if (op == DB_GET_RECNO) {
recno = *((db_recno_t *)data.data);
myobj = Tcl_NewWideIntObj((Tcl_WideInt)recno);
result = Tcl_ListObjAppendElement(interp, retlist, myobj);
} else {
if (flag & (DB_MULTIPLE|DB_MULTIPLE_KEY))
result = _SetMultiList(interp,
retlist, &key, &data, type, flag);
else if ((type == DB_RECNO || type == DB_QUEUE) &&
key.data != NULL) {
if (ispget)
result = _Set3DBTList(interp, retlist, &key, 1,
&data,
(ptype == DB_RECNO || ptype == DB_QUEUE),
&pdata);
else
result = _SetListRecnoElem(interp, retlist,
*(db_recno_t *)key.data,
data.data, data.size);
} else {
if (ispget)
result = _Set3DBTList(interp, retlist, &key, 0,
&data,
(ptype == DB_RECNO || ptype == DB_QUEUE),
&pdata);
else
result = _SetListElem(interp, retlist,
key.data, key.size, data.data, data.size);
}
}
out1:
if (result == TCL_OK)
Tcl_SetObjResult(interp, retlist);
/*
* If DB_DBT_MALLOC is set we need to free if DB allocated anything.
* If DB_DBT_USERMEM is set we need to free it because
* we allocated it (for data_buf_size/key_buf_size). That
* allocation does not apply to the pdata DBT.
*/
out:
if (key.data != NULL && F_ISSET(&key, DB_DBT_MALLOC))
__os_ufree(dbc->env, key.data);
if (key.data != NULL && F_ISSET(&key, DB_DBT_USERMEM))
__os_free(dbc->env, key.data);
if (data.data != NULL && F_ISSET(&data, DB_DBT_MALLOC))
__os_ufree(dbc->env, data.data);
if (data.data != NULL && F_ISSET(&data, DB_DBT_USERMEM))
__os_free(dbc->env, data.data);
if (pdata.data != NULL && F_ISSET(&pdata, DB_DBT_MALLOC))
__os_ufree(dbc->env, pdata.data);
if (freedata)
__os_free(NULL, dtmp);
if (freekey)
__os_free(NULL, ktmp);
return (result);
}
/*
* tcl_DbcDup --
*/
static int
tcl_DbcDup(interp, objc, objv, dbc)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DBC *dbc; /* Cursor pointer */
{
static const char *dbcdupopts[] = {
"-position",
NULL
};
enum dbcdupopts {
DBCDUP_POS
};
DBC *newdbc;
DBTCL_INFO *dbcip, *newdbcip, *dbip;
Tcl_Obj *res;
u_int32_t flag;
int i, optindex, result, ret;
char newname[MSG_SIZE];
result = TCL_OK;
flag = 0;
res = NULL;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args?");
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i], dbcdupopts,
"option", TCL_EXACT, &optindex) != TCL_OK) {
/*
* Reset the result so we don't get
* an errant error message if there is another error.
*/
if (IS_HELP(objv[i]) == TCL_OK) {
result = TCL_OK;
goto out;
}
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum dbcdupopts)optindex) {
case DBCDUP_POS:
flag = DB_POSITION;
break;
}
if (result != TCL_OK)
break;
}
if (result != TCL_OK)
goto out;
/*
* We need to determine if we are a recno database
* or not. If we are, then key.data is a recno, not
* a string.
*/
dbcip = _PtrToInfo(dbc);
if (dbcip == NULL) {
Tcl_SetResult(interp, "Cursor without info structure",
TCL_STATIC);
result = TCL_ERROR;
goto out;
} else {
dbip = dbcip->i_parent;
if (dbip == NULL) {
Tcl_SetResult(interp, "Cursor without parent database",
TCL_STATIC);
result = TCL_ERROR;
goto out;
}
}
/*
* Now duplicate the cursor. If successful, we need to create
* a new cursor command.
*/
snprintf(newname, sizeof(newname),
"%s.c%d", dbip->i_name, dbip->i_dbdbcid);
newdbcip = _NewInfo(interp, NULL, newname, I_DBC);
if (newdbcip != NULL) {
ret = dbc->dup(dbc, &newdbc, flag);
if (ret == 0) {
dbip->i_dbdbcid++;
newdbcip->i_parent = dbip;
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)dbc_Cmd,
(ClientData)newdbc, NULL);
res = NewStringObj(newname, strlen(newname));
_SetInfoData(newdbcip, newdbc);
Tcl_SetObjResult(interp, res);
} else {
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"db dup");
_DeleteInfo(newdbcip);
}
} else {
Tcl_SetResult(interp, "Could not set up info", TCL_STATIC);
result = TCL_ERROR;
}
out:
return (result);
}

2581
tcl/tcl_env.c Normal file
View File

File diff suppressed because it is too large Load Diff

814
tcl/tcl_internal.c Normal file
View File

@@ -0,0 +1,814 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_internal.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
#include "dbinc/db_page.h"
#include "dbinc/db_am.h"
/*
*
* internal.c --
*
* This file contains internal functions we need to maintain
* state for our Tcl interface.
*
* NOTE: This all uses a linear linked list. If we end up with
* too many info structs such that this is a performance hit, it
* should be redone using hashes or a list per type. The assumption
* is that the user won't have more than a few dozen info structs
* in operation at any given point in time. Even a complicated
* application with a few environments, nested transactions, locking,
* and several databases open, using cursors should not have a
* negative performance impact, in terms of searching the list to
* get/manipulate the info structure.
*/
#define GLOB_CHAR(c) ((c) == '*' || (c) == '?')
/*
* PUBLIC: DBTCL_INFO *_NewInfo __P((Tcl_Interp *,
* PUBLIC: void *, char *, enum INFOTYPE));
*
* _NewInfo --
*
* This function will create a new info structure and fill it in
* with the name and pointer, id and type.
*/
DBTCL_INFO *
_NewInfo(interp, anyp, name, type)
Tcl_Interp *interp;
void *anyp;
char *name;
enum INFOTYPE type;
{
DBTCL_INFO *p;
int ret;
if ((ret = __os_calloc(NULL, sizeof(DBTCL_INFO), 1, &p)) != 0) {
Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
return (NULL);
}
if ((ret = __os_strdup(NULL, name, &p->i_name)) != 0) {
Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
__os_free(NULL, p);
return (NULL);
}
p->i_interp = interp;
p->i_anyp = anyp;
p->i_type = type;
LIST_INSERT_HEAD(&__db_infohead, p, entries);
return (p);
}
/*
* PUBLIC: void *_NameToPtr __P((CONST char *));
*/
void *
_NameToPtr(name)
CONST char *name;
{
DBTCL_INFO *p;
LIST_FOREACH(p, &__db_infohead, entries)
if (strcmp(name, p->i_name) == 0)
return (p->i_anyp);
return (NULL);
}
/*
* PUBLIC: DBTCL_INFO *_PtrToInfo __P((CONST void *));
*/
DBTCL_INFO *
_PtrToInfo(ptr)
CONST void *ptr;
{
DBTCL_INFO *p;
LIST_FOREACH(p, &__db_infohead, entries)
if (p->i_anyp == ptr)
return (p);
return (NULL);
}
/*
* PUBLIC: DBTCL_INFO *_NameToInfo __P((CONST char *));
*/
DBTCL_INFO *
_NameToInfo(name)
CONST char *name;
{
DBTCL_INFO *p;
LIST_FOREACH(p, &__db_infohead, entries)
if (strcmp(name, p->i_name) == 0)
return (p);
return (NULL);
}
/*
* PUBLIC: void _SetInfoData __P((DBTCL_INFO *, void *));
*/
void
_SetInfoData(p, data)
DBTCL_INFO *p;
void *data;
{
if (p == NULL)
return;
p->i_anyp = data;
return;
}
/*
* PUBLIC: void _DeleteInfo __P((DBTCL_INFO *));
*/
void
_DeleteInfo(p)
DBTCL_INFO *p;
{
if (p == NULL)
return;
LIST_REMOVE(p, entries);
if (p->i_lockobj.data != NULL)
__os_free(NULL, p->i_lockobj.data);
if (p->i_err != NULL && p->i_err != stderr && p->i_err != stdout) {
(void)fclose(p->i_err);
p->i_err = NULL;
}
if (p->i_errpfx != NULL)
__os_free(NULL, p->i_errpfx);
if (p->i_compare != NULL) {
Tcl_DecrRefCount(p->i_compare);
}
if (p->i_dupcompare != NULL) {
Tcl_DecrRefCount(p->i_dupcompare);
}
if (p->i_hashproc != NULL) {
Tcl_DecrRefCount(p->i_hashproc);
}
if (p->i_second_call != NULL) {
Tcl_DecrRefCount(p->i_second_call);
}
if (p->i_rep_eid != NULL) {
Tcl_DecrRefCount(p->i_rep_eid);
}
if (p->i_rep_send != NULL) {
Tcl_DecrRefCount(p->i_rep_send);
}
if (p->i_event != NULL) {
Tcl_DecrRefCount(p->i_event);
}
__os_free(NULL, p->i_name);
__os_free(NULL, p);
return;
}
/*
* PUBLIC: int _SetListElem __P((Tcl_Interp *,
* PUBLIC: Tcl_Obj *, void *, u_int32_t, void *, u_int32_t));
*/
int
_SetListElem(interp, list, elem1, e1cnt, elem2, e2cnt)
Tcl_Interp *interp;
Tcl_Obj *list;
void *elem1, *elem2;
u_int32_t e1cnt, e2cnt;
{
Tcl_Obj *myobjv[2], *thislist;
int myobjc;
myobjc = 2;
myobjv[0] = Tcl_NewByteArrayObj((u_char *)elem1, (int)e1cnt);
myobjv[1] = Tcl_NewByteArrayObj((u_char *)elem2, (int)e2cnt);
thislist = Tcl_NewListObj(myobjc, myobjv);
if (thislist == NULL)
return (TCL_ERROR);
return (Tcl_ListObjAppendElement(interp, list, thislist));
}
/*
* PUBLIC: int _SetListElemInt __P((Tcl_Interp *, Tcl_Obj *, void *, long));
*/
int
_SetListElemInt(interp, list, elem1, elem2)
Tcl_Interp *interp;
Tcl_Obj *list;
void *elem1;
long elem2;
{
Tcl_Obj *myobjv[2], *thislist;
int myobjc;
myobjc = 2;
myobjv[0] =
Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1));
myobjv[1] = Tcl_NewLongObj(elem2);
thislist = Tcl_NewListObj(myobjc, myobjv);
if (thislist == NULL)
return (TCL_ERROR);
return (Tcl_ListObjAppendElement(interp, list, thislist));
}
/*
* Don't compile this code if we don't have sequences compiled into the DB
* library, it's likely because we don't have a 64-bit type, and trying to
* use int64_t is going to result in syntax errors.
*/
#ifdef HAVE_64BIT_TYPES
/*
* PUBLIC: int _SetListElemWideInt __P((Tcl_Interp *,
* PUBLIC: Tcl_Obj *, void *, int64_t));
*/
int
_SetListElemWideInt(interp, list, elem1, elem2)
Tcl_Interp *interp;
Tcl_Obj *list;
void *elem1;
int64_t elem2;
{
Tcl_Obj *myobjv[2], *thislist;
int myobjc;
myobjc = 2;
myobjv[0] =
Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1));
myobjv[1] = Tcl_NewWideIntObj(elem2);
thislist = Tcl_NewListObj(myobjc, myobjv);
if (thislist == NULL)
return (TCL_ERROR);
return (Tcl_ListObjAppendElement(interp, list, thislist));
}
#endif /* HAVE_64BIT_TYPES */
/*
* PUBLIC: int _SetListRecnoElem __P((Tcl_Interp *, Tcl_Obj *,
* PUBLIC: db_recno_t, u_char *, u_int32_t));
*/
int
_SetListRecnoElem(interp, list, elem1, elem2, e2size)
Tcl_Interp *interp;
Tcl_Obj *list;
db_recno_t elem1;
u_char *elem2;
u_int32_t e2size;
{
Tcl_Obj *myobjv[2], *thislist;
int myobjc;
myobjc = 2;
myobjv[0] = Tcl_NewWideIntObj((Tcl_WideInt)elem1);
myobjv[1] = Tcl_NewByteArrayObj(elem2, (int)e2size);
thislist = Tcl_NewListObj(myobjc, myobjv);
if (thislist == NULL)
return (TCL_ERROR);
return (Tcl_ListObjAppendElement(interp, list, thislist));
}
/*
* _Set3DBTList --
* This is really analogous to both _SetListElem and
* _SetListRecnoElem--it's used for three-DBT lists returned by
* DB->pget and DBC->pget(). We'd need a family of four functions
* to handle all the recno/non-recno cases, however, so we make
* this a little more aware of the internals and do the logic inside.
*
* XXX
* One of these days all these functions should probably be cleaned up
* to eliminate redundancy and bring them into the standard DB
* function namespace.
*
* PUBLIC: int _Set3DBTList __P((Tcl_Interp *, Tcl_Obj *, DBT *, int,
* PUBLIC: DBT *, int, DBT *));
*/
int
_Set3DBTList(interp, list, elem1, is1recno, elem2, is2recno, elem3)
Tcl_Interp *interp;
Tcl_Obj *list;
DBT *elem1, *elem2, *elem3;
int is1recno, is2recno;
{
Tcl_Obj *myobjv[3], *thislist;
if (is1recno)
myobjv[0] = Tcl_NewWideIntObj(
(Tcl_WideInt)*(db_recno_t *)elem1->data);
else
myobjv[0] = Tcl_NewByteArrayObj(
(u_char *)elem1->data, (int)elem1->size);
if (is2recno)
myobjv[1] = Tcl_NewWideIntObj(
(Tcl_WideInt)*(db_recno_t *)elem2->data);
else
myobjv[1] = Tcl_NewByteArrayObj(
(u_char *)elem2->data, (int)elem2->size);
myobjv[2] = Tcl_NewByteArrayObj(
(u_char *)elem3->data, (int)elem3->size);
thislist = Tcl_NewListObj(3, myobjv);
if (thislist == NULL)
return (TCL_ERROR);
return (Tcl_ListObjAppendElement(interp, list, thislist));
}
/*
* _SetMultiList -- build a list for return from multiple get.
*
* PUBLIC: int _SetMultiList __P((Tcl_Interp *,
* PUBLIC: Tcl_Obj *, DBT *, DBT*, DBTYPE, u_int32_t));
*/
int
_SetMultiList(interp, list, key, data, type, flag)
Tcl_Interp *interp;
Tcl_Obj *list;
DBT *key, *data;
DBTYPE type;
u_int32_t flag;
{
db_recno_t recno;
u_int32_t dlen, klen;
int result;
void *pointer, *dp, *kp;
recno = 0;
dlen = 0;
kp = NULL;
DB_MULTIPLE_INIT(pointer, data);
result = TCL_OK;
if (type == DB_RECNO || type == DB_QUEUE)
recno = *(db_recno_t *) key->data;
else
kp = key->data;
klen = key->size;
do {
if (flag & DB_MULTIPLE_KEY) {
if (type == DB_RECNO || type == DB_QUEUE)
DB_MULTIPLE_RECNO_NEXT(pointer,
data, recno, dp, dlen);
else
DB_MULTIPLE_KEY_NEXT(pointer,
data, kp, klen, dp, dlen);
} else
DB_MULTIPLE_NEXT(pointer, data, dp, dlen);
if (pointer == NULL)
break;
if (type == DB_RECNO || type == DB_QUEUE) {
result =
_SetListRecnoElem(interp, list, recno, dp, dlen);
recno++;
/* Wrap around and skip zero. */
if (recno == 0)
recno++;
} else
result = _SetListElem(interp, list, kp, klen, dp, dlen);
} while (result == TCL_OK);
return (result);
}
/*
* PUBLIC: int _GetGlobPrefix __P((char *, char **));
*/
int
_GetGlobPrefix(pattern, prefix)
char *pattern;
char **prefix;
{
int i, j;
char *p;
/*
* Duplicate it, we get enough space and most of the work is done.
*/
if (__os_strdup(NULL, pattern, prefix) != 0)
return (1);
p = *prefix;
for (i = 0, j = 0; p[i] && !GLOB_CHAR(p[i]); i++, j++)
/*
* Check for an escaped character and adjust
*/
if (p[i] == '\\' && p[i+1]) {
p[j] = p[i+1];
i++;
} else
p[j] = p[i];
p[j] = 0;
return (0);
}
/*
* PUBLIC: int _ReturnSetup __P((Tcl_Interp *, int, int, char *));
*/
int
_ReturnSetup(interp, ret, ok, errmsg)
Tcl_Interp *interp;
int ret, ok;
char *errmsg;
{
char *msg;
if (ret > 0)
return (_ErrorSetup(interp, ret, errmsg));
/*
* We either have success or a DB error. If a DB error, set up the
* string. We return an error if not one of the errors we catch.
* If anyone wants to reset the result to return anything different,
* then the calling function is responsible for doing so via
* Tcl_ResetResult or another Tcl_SetObjResult.
*/
if (ret == 0) {
Tcl_SetResult(interp, "0", TCL_STATIC);
return (TCL_OK);
}
msg = db_strerror(ret);
Tcl_AppendResult(interp, msg, NULL);
if (ok)
return (TCL_OK);
else {
Tcl_SetErrorCode(interp, "BerkeleyDB", msg, NULL);
return (TCL_ERROR);
}
}
/*
* PUBLIC: int _ErrorSetup __P((Tcl_Interp *, int, char *));
*/
int
_ErrorSetup(interp, ret, errmsg)
Tcl_Interp *interp;
int ret;
char *errmsg;
{
Tcl_SetErrno(ret);
Tcl_AppendResult(interp, errmsg, ":", Tcl_PosixError(interp), NULL);
return (TCL_ERROR);
}
/*
* PUBLIC: void _ErrorFunc __P((const DB_ENV *, CONST char *, const char *));
*/
void
_ErrorFunc(dbenv, pfx, msg)
const DB_ENV *dbenv;
CONST char *pfx;
const char *msg;
{
DBTCL_INFO *p;
Tcl_Interp *interp;
size_t size;
char *err;
COMPQUIET(dbenv, NULL);
p = _NameToInfo(pfx);
if (p == NULL)
return;
interp = p->i_interp;
size = strlen(pfx) + strlen(msg) + 4;
/*
* If we cannot allocate enough to put together the prefix
* and message then give them just the message.
*/
if (__os_malloc(NULL, size, &err) != 0) {
Tcl_AddErrorInfo(interp, msg);
Tcl_AppendResult(interp, msg, "\n", NULL);
return;
}
snprintf(err, size, "%s: %s", pfx, msg);
Tcl_AddErrorInfo(interp, err);
Tcl_AppendResult(interp, err, "\n", NULL);
__os_free(NULL, err);
return;
}
/*
* PUBLIC: void _EventFunc __P((DB_ENV *, u_int32_t, void *));
*/
void
_EventFunc(dbenv, event, info)
DB_ENV *dbenv;
u_int32_t event;
void *info;
{
#define TCLDB_EVENTITEMS 2 /* Event name and any info */
#define TCLDB_SENDEVENT 3 /* Event Tcl proc, env name, event objects. */
DBTCL_INFO *ip;
Tcl_Interp *interp;
Tcl_Obj *event_o, *origobj;
Tcl_Obj *myobjv[TCLDB_EVENTITEMS], *objv[TCLDB_SENDEVENT];
int i, myobjc, result;
ip = (DBTCL_INFO *)dbenv->app_private;
interp = ip->i_interp;
if (ip->i_event == NULL)
return;
objv[0] = ip->i_event;
objv[1] = NewStringObj(ip->i_name, strlen(ip->i_name));
/*
* Most events don't have additional info. Assume none
* and handle individually those that do.
*/
myobjv[1] = NULL;
myobjc = 1;
switch (event) {
case DB_EVENT_PANIC:
/*
* Info is the original error code.
*/
myobjv[0] = NewStringObj("panic", strlen("panic"));
myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info);
break;
case DB_EVENT_REP_CLIENT:
myobjv[0] = NewStringObj("rep_client", strlen("rep_client"));
break;
case DB_EVENT_REP_ELECTED:
myobjv[0] = NewStringObj("elected", strlen("elected"));
break;
case DB_EVENT_REP_MASTER:
myobjv[0] = NewStringObj("rep_master", strlen("rep_master"));
break;
case DB_EVENT_REP_NEWMASTER:
/*
* Info is the EID of the new master.
*/
myobjv[0] = NewStringObj("newmaster", strlen("newmaster"));
myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info);
break;
case DB_EVENT_REP_PERM_FAILED:
myobjv[0] = NewStringObj("perm_failed", strlen("perm_failed"));
break;
case DB_EVENT_REP_STARTUPDONE:
myobjv[0] = NewStringObj("startupdone", strlen("startupdone"));
break;
case DB_EVENT_WRITE_FAILED:
myobjv[0] =
NewStringObj("write_failed", strlen("write_failed"));
break;
default:
__db_errx(dbenv->env, "Tcl unknown event %lu", (u_long)event);
return;
}
for (i = 0; i < myobjc; i++)
Tcl_IncrRefCount(myobjv[i]);
event_o = Tcl_NewListObj(myobjc, myobjv);
Tcl_IncrRefCount(event_o);
objv[2] = event_o;
/*
* We really want to return the original result to the
* user. So, save the result obj here, and then after
* we've taken care of the Tcl_EvalObjv, set the result
* back to this original result.
*/
origobj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(origobj);
result = Tcl_EvalObjv(interp, TCLDB_SENDEVENT, objv, 0);
if (result != TCL_OK) {
/*
* XXX
* This probably isn't the right error behavior, but
* this error should only happen if the Tcl callback is
* somehow invalid, which is a fatal scripting bug.
* The event handler is a void function so we either
* just return or abort.
* For now, abort.
*/
__db_errx(dbenv->env, "Tcl event failure");
__os_abort(dbenv->env);
}
Tcl_SetObjResult(interp, origobj);
Tcl_DecrRefCount(origobj);
for (i = 0; i < myobjc; i++)
Tcl_DecrRefCount(myobjv[i]);
Tcl_DecrRefCount(event_o);
return;
}
#define INVALID_LSNMSG "Invalid LSN with %d parts. Should have 2.\n"
/*
* PUBLIC: int _GetLsn __P((Tcl_Interp *, Tcl_Obj *, DB_LSN *));
*/
int
_GetLsn(interp, obj, lsn)
Tcl_Interp *interp;
Tcl_Obj *obj;
DB_LSN *lsn;
{
Tcl_Obj **myobjv;
char msg[MSG_SIZE];
int myobjc, result;
u_int32_t tmp;
result = Tcl_ListObjGetElements(interp, obj, &myobjc, &myobjv);
if (result == TCL_ERROR)
return (result);
if (myobjc != 2) {
result = TCL_ERROR;
snprintf(msg, MSG_SIZE, INVALID_LSNMSG, myobjc);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return (result);
}
result = _GetUInt32(interp, myobjv[0], &tmp);
if (result == TCL_ERROR)
return (result);
lsn->file = tmp;
result = _GetUInt32(interp, myobjv[1], &tmp);
lsn->offset = tmp;
return (result);
}
/*
* _GetUInt32 --
* Get a u_int32_t from a Tcl object. Tcl_GetIntFromObj does the
* right thing most of the time, but on machines where a long is 8 bytes
* and an int is 4 bytes, it errors on integers between the maximum
* int32_t and the maximum u_int32_t. This is correct, but we generally
* want a u_int32_t in the end anyway, so we use Tcl_GetLongFromObj and do
* the bounds checking ourselves.
*
* This code looks much like Tcl_GetIntFromObj, only with a different
* bounds check. It's essentially Tcl_GetUnsignedIntFromObj, which
* unfortunately doesn't exist.
*
* PUBLIC: int _GetUInt32 __P((Tcl_Interp *, Tcl_Obj *, u_int32_t *));
*/
int
_GetUInt32(interp, obj, resp)
Tcl_Interp *interp;
Tcl_Obj *obj;
u_int32_t *resp;
{
int result;
long ltmp;
result = Tcl_GetLongFromObj(interp, obj, &ltmp);
if (result != TCL_OK)
return (result);
if ((unsigned long)ltmp != (u_int32_t)ltmp) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large for u_int32_t", -1);
}
return (TCL_ERROR);
}
*resp = (u_int32_t)ltmp;
return (TCL_OK);
}
/*
* _GetFlagsList --
* Get a new Tcl object, containing a list of the string values
* associated with a particular set of flag values.
*
* PUBLIC: Tcl_Obj *_GetFlagsList __P((Tcl_Interp *, u_int32_t, const FN *));
*/
Tcl_Obj *
_GetFlagsList(interp, flags, fnp)
Tcl_Interp *interp;
u_int32_t flags;
const FN *fnp;
{
Tcl_Obj *newlist, *newobj;
int result;
newlist = Tcl_NewObj();
/*
* If the Berkeley DB library wasn't compiled with statistics, then
* we may get a NULL reference.
*/
if (fnp == NULL)
return (newlist);
/*
* Append a Tcl_Obj containing each pertinent flag string to the
* specified Tcl list.
*/
for (; fnp->mask != 0; ++fnp)
if (LF_ISSET(fnp->mask)) {
newobj = NewStringObj(fnp->name, strlen(fnp->name));
result =
Tcl_ListObjAppendElement(interp, newlist, newobj);
/*
* Tcl_ListObjAppendElement is defined to return TCL_OK
* unless newlist isn't actually a list (or convertible
* into one). If this is the case, we screwed up badly
* somehow.
*/
DB_ASSERT(NULL, result == TCL_OK);
}
return (newlist);
}
int __debug_stop, __debug_on, __debug_print, __debug_test;
/*
* PUBLIC: void _debug_check __P((void));
*/
void
_debug_check()
{
if (__debug_on == 0)
return;
if (__debug_print != 0) {
printf("\r%7d:", __debug_on);
(void)fflush(stdout);
}
if (__debug_on++ == __debug_test || __debug_stop)
__db_loadme();
}
/*
* XXX
* Tcl 8.1+ Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug.
*
* There is a bug in Tcl 8.1+ and byte arrays in that if it happens
* to use an object as both a byte array and something else like
* an int, and you've done a Tcl_GetByteArrayFromObj, then you
* do a Tcl_GetIntFromObj, your memory is deleted.
*
* Workaround is for all byte arrays we want to use, if it can be
* represented as an integer, we copy it so that we don't lose the
* memory.
*/
/*
* PUBLIC: int _CopyObjBytes __P((Tcl_Interp *, Tcl_Obj *obj, void *,
* PUBLIC: u_int32_t *, int *));
*/
int
_CopyObjBytes(interp, obj, newp, sizep, freep)
Tcl_Interp *interp;
Tcl_Obj *obj;
void *newp;
u_int32_t *sizep;
int *freep;
{
void *tmp, *new;
int i, len, ret;
/*
* If the object is not an int, then just return the byte
* array because it won't be transformed out from under us.
* If it is a number, we need to copy it.
*/
*freep = 0;
ret = Tcl_GetIntFromObj(interp, obj, &i);
tmp = Tcl_GetByteArrayFromObj(obj, &len);
*sizep = (u_int32_t)len;
if (ret == TCL_ERROR) {
Tcl_ResetResult(interp);
*(void **)newp = tmp;
return (0);
}
/*
* If we get here, we have an integer that might be reused
* at some other point so we cannot count on GetByteArray
* keeping our pointer valid.
*/
if ((ret = __os_malloc(NULL, (size_t)len, &new)) != 0)
return (ret);
memcpy(new, tmp, (size_t)len);
*(void **)newp = new;
*freep = 1;
return (0);
}

775
tcl/tcl_lock.c Normal file
View File

@@ -0,0 +1,775 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_lock.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
/*
* Prototypes for procedures defined later in this file:
*/
#ifdef CONFIG_TEST
static int lock_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
static int _LockMode __P((Tcl_Interp *, Tcl_Obj *, db_lockmode_t *));
static int _GetThisLock __P((Tcl_Interp *, DB_ENV *, u_int32_t,
u_int32_t, DBT *, db_lockmode_t, char *));
static void _LockPutInfo __P((Tcl_Interp *, db_lockop_t, DB_LOCK *,
u_int32_t, DBT *));
/*
* tcl_LockDetect --
*
* PUBLIC: int tcl_LockDetect __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LockDetect(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
static const char *ldopts[] = {
"default",
"expire",
"maxlocks",
"maxwrites",
"minlocks",
"minwrites",
"oldest",
"random",
"youngest",
NULL
};
enum ldopts {
LD_DEFAULT,
LD_EXPIRE,
LD_MAXLOCKS,
LD_MAXWRITES,
LD_MINLOCKS,
LD_MINWRITES,
LD_OLDEST,
LD_RANDOM,
LD_YOUNGEST
};
u_int32_t flag, policy;
int i, optindex, result, ret;
result = TCL_OK;
flag = policy = 0;
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
ldopts, "option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[i]));
i++;
switch ((enum ldopts)optindex) {
case LD_DEFAULT:
FLAG_CHECK(policy);
policy = DB_LOCK_DEFAULT;
break;
case LD_EXPIRE:
FLAG_CHECK(policy);
policy = DB_LOCK_EXPIRE;
break;
case LD_MAXLOCKS:
FLAG_CHECK(policy);
policy = DB_LOCK_MAXLOCKS;
break;
case LD_MAXWRITES:
FLAG_CHECK(policy);
policy = DB_LOCK_MAXWRITE;
break;
case LD_MINLOCKS:
FLAG_CHECK(policy);
policy = DB_LOCK_MINLOCKS;
break;
case LD_MINWRITES:
FLAG_CHECK(policy);
policy = DB_LOCK_MINWRITE;
break;
case LD_OLDEST:
FLAG_CHECK(policy);
policy = DB_LOCK_OLDEST;
break;
case LD_RANDOM:
FLAG_CHECK(policy);
policy = DB_LOCK_RANDOM;
break;
case LD_YOUNGEST:
FLAG_CHECK(policy);
policy = DB_LOCK_YOUNGEST;
break;
}
}
_debug_check();
ret = dbenv->lock_detect(dbenv, flag, policy, NULL);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock detect");
return (result);
}
/*
* tcl_LockGet --
*
* PUBLIC: int tcl_LockGet __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LockGet(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
static const char *lgopts[] = {
"-nowait",
NULL
};
enum lgopts {
LGNOWAIT
};
DBT obj;
Tcl_Obj *res;
void *otmp;
db_lockmode_t mode;
u_int32_t flag, lockid;
int freeobj, optindex, result, ret;
char newname[MSG_SIZE];
result = TCL_OK;
freeobj = 0;
memset(newname, 0, MSG_SIZE);
if (objc != 5 && objc != 6) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nowait? mode id obj");
return (TCL_ERROR);
}
/*
* Work back from required args.
* Last arg is obj.
* Second last is lock id.
* Third last is lock mode.
*/
memset(&obj, 0, sizeof(obj));
if ((result =
_GetUInt32(interp, objv[objc-2], &lockid)) != TCL_OK)
return (result);
ret = _CopyObjBytes(interp, objv[objc-1], &otmp,
&obj.size, &freeobj);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "lock get");
return (result);
}
obj.data = otmp;
if ((result = _LockMode(interp, objv[(objc - 3)], &mode)) != TCL_OK)
goto out;
/*
* Any left over arg is the flag.
*/
flag = 0;
if (objc == 6) {
if (Tcl_GetIndexFromObj(interp, objv[(objc - 4)],
lgopts, "option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[(objc - 4)]));
switch ((enum lgopts)optindex) {
case LGNOWAIT:
flag |= DB_LOCK_NOWAIT;
break;
}
}
result = _GetThisLock(interp, dbenv, lockid, flag, &obj, mode, newname);
if (result == TCL_OK) {
res = NewStringObj(newname, strlen(newname));
Tcl_SetObjResult(interp, res);
}
out:
if (freeobj)
__os_free(dbenv->env, otmp);
return (result);
}
/*
* tcl_LockStat --
*
* PUBLIC: int tcl_LockStat __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LockStat(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_LOCK_STAT *sp;
Tcl_Obj *res;
int result, ret;
result = TCL_OK;
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->lock_stat(dbenv, &sp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock stat");
if (result == TCL_ERROR)
return (result);
/*
* Have our stats, now construct the name value
* list pairs and free up the memory.
*/
res = Tcl_NewObj();
#ifdef HAVE_STATISTICS
/*
* MAKE_STAT_LIST assumes 'res' and 'error' label.
*/
MAKE_STAT_LIST("Region size", sp->st_regsize);
MAKE_STAT_LIST("Last allocated locker ID", sp->st_id);
MAKE_STAT_LIST("Current maximum unused locker ID", sp->st_cur_maxid);
MAKE_STAT_LIST("Maximum locks", sp->st_maxlocks);
MAKE_STAT_LIST("Maximum lockers", sp->st_maxlockers);
MAKE_STAT_LIST("Maximum objects", sp->st_maxobjects);
MAKE_STAT_LIST("Lock modes", sp->st_nmodes);
MAKE_STAT_LIST("Number of lock table partitions", sp->st_partitions);
MAKE_STAT_LIST("Current number of locks", sp->st_nlocks);
MAKE_STAT_LIST("Maximum number of locks so far", sp->st_maxnlocks);
MAKE_STAT_LIST("Maximum number of locks in any hash bucket",
sp->st_maxhlocks);
MAKE_STAT_LIST("Maximum number of lock steals for an empty partition",
sp->st_locksteals);
MAKE_STAT_LIST("Maximum number lock steals in any partition",
sp->st_maxlsteals);
MAKE_STAT_LIST("Current number of lockers", sp->st_nlockers);
MAKE_STAT_LIST("Maximum number of lockers so far", sp->st_maxnlockers);
MAKE_STAT_LIST("Current number of objects", sp->st_nobjects);
MAKE_STAT_LIST("Maximum number of objects so far", sp->st_maxnobjects);
MAKE_STAT_LIST("Maximum number of objects in any hash bucket",
sp->st_maxhobjects);
MAKE_STAT_LIST("Maximum number of object steals for an empty partition",
sp->st_objectsteals);
MAKE_STAT_LIST("Maximum number object steals in any partition",
sp->st_maxosteals);
MAKE_STAT_LIST("Lock requests", sp->st_nrequests);
MAKE_STAT_LIST("Lock releases", sp->st_nreleases);
MAKE_STAT_LIST("Lock upgrades", sp->st_nupgrade);
MAKE_STAT_LIST("Lock downgrades", sp->st_ndowngrade);
MAKE_STAT_LIST("Number of conflicted locks for which we waited",
sp->st_lock_wait);
MAKE_STAT_LIST("Number of conflicted locks for which we did not wait",
sp->st_lock_nowait);
MAKE_STAT_LIST("Deadlocks detected", sp->st_ndeadlocks);
MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
MAKE_STAT_LIST("Number of object allocation waits", sp->st_objs_wait);
MAKE_STAT_LIST("Number of object allocation nowaits",
sp->st_objs_nowait);
MAKE_STAT_LIST("Number of locker allocation waits",
sp->st_lockers_wait);
MAKE_STAT_LIST("Number of locker allocation nowaits",
sp->st_lockers_nowait);
MAKE_STAT_LIST("Maximum hash bucket length", sp->st_hash_len);
MAKE_STAT_LIST("Lock timeout value", sp->st_locktimeout);
MAKE_STAT_LIST("Number of lock timeouts", sp->st_nlocktimeouts);
MAKE_STAT_LIST("Transaction timeout value", sp->st_txntimeout);
MAKE_STAT_LIST("Number of transaction timeouts", sp->st_ntxntimeouts);
MAKE_STAT_LIST("Number lock partition mutex waits", sp->st_part_wait);
MAKE_STAT_LIST("Number lock partition mutex nowaits",
sp->st_part_nowait);
MAKE_STAT_LIST("Maximum number waits on any lock partition mutex",
sp->st_part_max_wait);
MAKE_STAT_LIST("Maximum number nowaits on any lock partition mutex",
sp->st_part_max_nowait);
#endif
Tcl_SetObjResult(interp, res);
error:
__os_ufree(dbenv->env, sp);
return (result);
}
/*
* tcl_LockTimeout --
*
* PUBLIC: int tcl_LockTimeout __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LockTimeout(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
long timeout;
int result, ret;
/*
* One arg, the timeout.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?timeout?");
return (TCL_ERROR);
}
result = Tcl_GetLongFromObj(interp, objv[2], &timeout);
if (result != TCL_OK)
return (result);
_debug_check();
ret = dbenv->set_timeout(dbenv, (u_int32_t)timeout,
DB_SET_LOCK_TIMEOUT);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock timeout");
return (result);
}
/*
* lock_Cmd --
* Implements the "lock" widget.
*/
static int
lock_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Lock handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *lkcmds[] = {
"put",
NULL
};
enum lkcmds {
LKPUT
};
DB_ENV *dbenv;
DB_LOCK *lock;
DBTCL_INFO *lkip;
int cmdindex, result, ret;
Tcl_ResetResult(interp);
lock = (DB_LOCK *)clientData;
lkip = _PtrToInfo((void *)lock);
result = TCL_OK;
if (lock == NULL) {
Tcl_SetResult(interp, "NULL lock", TCL_STATIC);
return (TCL_ERROR);
}
if (lkip == NULL) {
Tcl_SetResult(interp, "NULL lock info pointer", TCL_STATIC);
return (TCL_ERROR);
}
dbenv = NAME_TO_ENV(lkip->i_parent->i_name);
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], lkcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
switch ((enum lkcmds)cmdindex) {
case LKPUT:
_debug_check();
ret = dbenv->lock_put(dbenv, lock);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"lock put");
(void)Tcl_DeleteCommand(interp, lkip->i_name);
_DeleteInfo(lkip);
__os_free(dbenv->env, lock);
break;
}
return (result);
}
/*
* tcl_LockVec --
*
* PUBLIC: int tcl_LockVec __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LockVec(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* environment pointer */
{
static const char *lvopts[] = {
"-nowait",
NULL
};
enum lvopts {
LVNOWAIT
};
static const char *lkops[] = {
"get",
"put",
"put_all",
"put_obj",
"timeout",
NULL
};
enum lkops {
LKGET,
LKPUT,
LKPUTALL,
LKPUTOBJ,
LKTIMEOUT
};
DB_LOCK *lock;
DB_LOCKREQ list;
DBT obj;
Tcl_Obj **myobjv, *res, *thisop;
void *otmp;
u_int32_t flag, lockid;
int freeobj, i, myobjc, optindex, result, ret;
char *lockname, msg[MSG_SIZE], newname[MSG_SIZE];
result = TCL_OK;
memset(newname, 0, MSG_SIZE);
memset(&list, 0, sizeof(DB_LOCKREQ));
flag = 0;
freeobj = 0;
otmp = NULL;
/*
* If -nowait is given, it MUST be first arg.
*/
if (Tcl_GetIndexFromObj(interp, objv[2],
lvopts, "option", TCL_EXACT, &optindex) == TCL_OK) {
switch ((enum lvopts)optindex) {
case LVNOWAIT:
flag |= DB_LOCK_NOWAIT;
break;
}
i = 3;
} else {
if (IS_HELP(objv[2]) == TCL_OK)
return (TCL_OK);
Tcl_ResetResult(interp);
i = 2;
}
/*
* Our next arg MUST be the locker ID.
*/
result = _GetUInt32(interp, objv[i++], &lockid);
if (result != TCL_OK)
return (result);
/*
* All other remaining args are operation tuples.
* Go through sequentially to decode, execute and build
* up list of return values.
*/
res = Tcl_NewListObj(0, NULL);
while (i < objc) {
/*
* Get the list of the tuple.
*/
lock = NULL;
result = Tcl_ListObjGetElements(interp, objv[i],
&myobjc, &myobjv);
if (result == TCL_OK)
i++;
else
break;
/*
* First we will set up the list of requests.
* We will make a "second pass" after we get back
* the results from the lock_vec call to create
* the return list.
*/
if (Tcl_GetIndexFromObj(interp, myobjv[0],
lkops, "option", TCL_EXACT, &optindex) != TCL_OK) {
result = IS_HELP(myobjv[0]);
goto error;
}
switch ((enum lkops)optindex) {
case LKGET:
if (myobjc != 3) {
Tcl_WrongNumArgs(interp, 1, myobjv,
"{get obj mode}");
result = TCL_ERROR;
goto error;
}
result = _LockMode(interp, myobjv[2], &list.mode);
if (result != TCL_OK)
goto error;
ret = _CopyObjBytes(interp, myobjv[1], &otmp,
&obj.size, &freeobj);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "lock vec");
return (result);
}
obj.data = otmp;
ret = _GetThisLock(interp, dbenv, lockid, flag,
&obj, list.mode, newname);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "lock vec");
thisop = Tcl_NewIntObj(ret);
(void)Tcl_ListObjAppendElement(interp, res,
thisop);
goto error;
}
thisop = NewStringObj(newname, strlen(newname));
(void)Tcl_ListObjAppendElement(interp, res, thisop);
if (freeobj && otmp != NULL) {
__os_free(dbenv->env, otmp);
freeobj = 0;
}
continue;
case LKPUT:
if (myobjc != 2) {
Tcl_WrongNumArgs(interp, 1, myobjv,
"{put lock}");
result = TCL_ERROR;
goto error;
}
list.op = DB_LOCK_PUT;
lockname = Tcl_GetStringFromObj(myobjv[1], NULL);
lock = NAME_TO_LOCK(lockname);
if (lock == NULL) {
snprintf(msg, MSG_SIZE, "Invalid lock: %s\n",
lockname);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
result = TCL_ERROR;
goto error;
}
list.lock = *lock;
break;
case LKPUTALL:
if (myobjc != 1) {
Tcl_WrongNumArgs(interp, 1, myobjv,
"{put_all}");
result = TCL_ERROR;
goto error;
}
list.op = DB_LOCK_PUT_ALL;
break;
case LKPUTOBJ:
if (myobjc != 2) {
Tcl_WrongNumArgs(interp, 1, myobjv,
"{put_obj obj}");
result = TCL_ERROR;
goto error;
}
list.op = DB_LOCK_PUT_OBJ;
ret = _CopyObjBytes(interp, myobjv[1], &otmp,
&obj.size, &freeobj);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "lock vec");
return (result);
}
obj.data = otmp;
list.obj = &obj;
break;
case LKTIMEOUT:
list.op = DB_LOCK_TIMEOUT;
break;
}
/*
* We get here, we have set up our request, now call
* lock_vec.
*/
_debug_check();
ret = dbenv->lock_vec(dbenv, lockid, flag, &list, 1, NULL);
/*
* Now deal with whether or not the operation succeeded.
* Get's were done above, all these are only puts.
*/
thisop = Tcl_NewIntObj(ret);
result = Tcl_ListObjAppendElement(interp, res, thisop);
if (ret != 0 && result == TCL_OK)
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "lock put");
if (freeobj && otmp != NULL) {
__os_free(dbenv->env, otmp);
freeobj = 0;
}
/*
* We did a put of some kind. Since we did that,
* we have to delete the commands associated with
* any of the locks we just put.
*/
_LockPutInfo(interp, list.op, lock, lockid, &obj);
}
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
error:
return (result);
}
static int
_LockMode(interp, obj, mode)
Tcl_Interp *interp;
Tcl_Obj *obj;
db_lockmode_t *mode;
{
static const char *lkmode[] = {
"ng",
"read",
"write",
"iwrite",
"iread",
"iwr",
NULL
};
enum lkmode {
LK_NG,
LK_READ,
LK_WRITE,
LK_IWRITE,
LK_IREAD,
LK_IWR
};
int optindex;
if (Tcl_GetIndexFromObj(interp, obj, lkmode, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(obj));
switch ((enum lkmode)optindex) {
case LK_NG:
*mode = DB_LOCK_NG;
break;
case LK_READ:
*mode = DB_LOCK_READ;
break;
case LK_WRITE:
*mode = DB_LOCK_WRITE;
break;
case LK_IREAD:
*mode = DB_LOCK_IREAD;
break;
case LK_IWRITE:
*mode = DB_LOCK_IWRITE;
break;
case LK_IWR:
*mode = DB_LOCK_IWR;
break;
}
return (TCL_OK);
}
static void
_LockPutInfo(interp, op, lock, lockid, objp)
Tcl_Interp *interp;
db_lockop_t op;
DB_LOCK *lock;
u_int32_t lockid;
DBT *objp;
{
DBTCL_INFO *p, *nextp;
int found;
for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
found = 0;
nextp = LIST_NEXT(p, entries);
if ((op == DB_LOCK_PUT && (p->i_lock == lock)) ||
(op == DB_LOCK_PUT_ALL && p->i_locker == lockid) ||
(op == DB_LOCK_PUT_OBJ && p->i_lockobj.data &&
memcmp(p->i_lockobj.data, objp->data, objp->size) == 0))
found = 1;
if (found) {
(void)Tcl_DeleteCommand(interp, p->i_name);
__os_free(NULL, p->i_lock);
_DeleteInfo(p);
}
}
}
static int
_GetThisLock(interp, dbenv, lockid, flag, objp, mode, newname)
Tcl_Interp *interp; /* Interpreter */
DB_ENV *dbenv; /* Env handle */
u_int32_t lockid; /* Locker ID */
u_int32_t flag; /* Lock flag */
DBT *objp; /* Object to lock */
db_lockmode_t mode; /* Lock mode */
char *newname; /* New command name */
{
DBTCL_INFO *envip, *ip;
DB_LOCK *lock;
int result, ret;
result = TCL_OK;
envip = _PtrToInfo((void *)dbenv);
if (envip == NULL) {
Tcl_SetResult(interp, "Could not find env info\n", TCL_STATIC);
return (TCL_ERROR);
}
snprintf(newname, MSG_SIZE, "%s.lock%d",
envip->i_name, envip->i_envlockid);
ip = _NewInfo(interp, NULL, newname, I_LOCK);
if (ip == NULL) {
Tcl_SetResult(interp, "Could not set up info",
TCL_STATIC);
return (TCL_ERROR);
}
ret = __os_malloc(dbenv->env, sizeof(DB_LOCK), &lock);
if (ret != 0) {
Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->lock_get(dbenv, lockid, flag, objp, mode, lock);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock get");
if (result == TCL_ERROR) {
__os_free(dbenv->env, lock);
_DeleteInfo(ip);
return (result);
}
/*
* Success. Set up return. Set up new info
* and command widget for this lock.
*/
ret = __os_malloc(dbenv->env, objp->size, &ip->i_lockobj.data);
if (ret != 0) {
Tcl_SetResult(interp, "Could not duplicate obj",
TCL_STATIC);
(void)dbenv->lock_put(dbenv, lock);
__os_free(dbenv->env, lock);
_DeleteInfo(ip);
result = TCL_ERROR;
goto error;
}
memcpy(ip->i_lockobj.data, objp->data, objp->size);
ip->i_lockobj.size = objp->size;
envip->i_envlockid++;
ip->i_parent = envip;
ip->i_locker = lockid;
_SetInfoData(ip, lock);
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)lock_Cmd, (ClientData)lock, NULL);
error:
return (result);
}
#endif

770
tcl/tcl_log.c Normal file
View File

@@ -0,0 +1,770 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_log.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/log.h"
#include "dbinc/tcl_db.h"
#ifdef CONFIG_TEST
static int tcl_LogcGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_LOGC *));
/*
* tcl_LogArchive --
*
* PUBLIC: int tcl_LogArchive __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogArchive(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
static const char *archopts[] = {
"-arch_abs", "-arch_data", "-arch_log", "-arch_remove",
NULL
};
enum archopts {
ARCH_ABS, ARCH_DATA, ARCH_LOG, ARCH_REMOVE
};
Tcl_Obj *fileobj, *res;
u_int32_t flag;
int i, optindex, result, ret;
char **file, **list;
result = TCL_OK;
flag = 0;
/*
* Get the flag index from the object based on the options
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
archopts, "option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[i]));
i++;
switch ((enum archopts)optindex) {
case ARCH_ABS:
flag |= DB_ARCH_ABS;
break;
case ARCH_DATA:
flag |= DB_ARCH_DATA;
break;
case ARCH_LOG:
flag |= DB_ARCH_LOG;
break;
case ARCH_REMOVE:
flag |= DB_ARCH_REMOVE;
break;
}
}
_debug_check();
list = NULL;
ret = dbenv->log_archive(dbenv, &list, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log archive");
if (result == TCL_OK) {
res = Tcl_NewListObj(0, NULL);
for (file = list; file != NULL && *file != NULL; file++) {
fileobj = NewStringObj(*file, strlen(*file));
result = Tcl_ListObjAppendElement(interp, res, fileobj);
if (result != TCL_OK)
break;
}
Tcl_SetObjResult(interp, res);
}
if (list != NULL)
__os_ufree(dbenv->env, list);
return (result);
}
/*
* tcl_LogCompare --
*
* PUBLIC: int tcl_LogCompare __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*));
*/
int
tcl_LogCompare(interp, objc, objv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
DB_LSN lsn0, lsn1;
Tcl_Obj *res;
int result, ret;
result = TCL_OK;
/*
* No flags, must be 4 args.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "lsn1 lsn2");
return (TCL_ERROR);
}
result = _GetLsn(interp, objv[2], &lsn0);
if (result == TCL_ERROR)
return (result);
result = _GetLsn(interp, objv[3], &lsn1);
if (result == TCL_ERROR)
return (result);
_debug_check();
ret = log_compare(&lsn0, &lsn1);
res = Tcl_NewIntObj(ret);
Tcl_SetObjResult(interp, res);
return (result);
}
/*
* tcl_LogFile --
*
* PUBLIC: int tcl_LogFile __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogFile(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_LSN lsn;
Tcl_Obj *res;
size_t len;
int result, ret;
char *name;
result = TCL_OK;
/*
* No flags, must be 3 args.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "lsn");
return (TCL_ERROR);
}
result = _GetLsn(interp, objv[2], &lsn);
if (result == TCL_ERROR)
return (result);
len = MSG_SIZE;
ret = ENOMEM;
name = NULL;
while (ret == ENOMEM) {
if (name != NULL)
__os_free(dbenv->env, name);
ret = __os_malloc(dbenv->env, len, &name);
if (ret != 0) {
Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
break;
}
_debug_check();
ret = dbenv->log_file(dbenv, &lsn, name, len);
len *= 2;
}
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log_file");
if (ret == 0) {
res = NewStringObj(name, strlen(name));
Tcl_SetObjResult(interp, res);
}
if (name != NULL)
__os_free(dbenv->env, name);
return (result);
}
/*
* tcl_LogFlush --
*
* PUBLIC: int tcl_LogFlush __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogFlush(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_LSN lsn, *lsnp;
int result, ret;
result = TCL_OK;
/*
* No flags, must be 2 or 3 args.
*/
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?lsn?");
return (TCL_ERROR);
}
if (objc == 3) {
lsnp = &lsn;
result = _GetLsn(interp, objv[2], &lsn);
if (result == TCL_ERROR)
return (result);
} else
lsnp = NULL;
_debug_check();
ret = dbenv->log_flush(dbenv, lsnp);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log_flush");
return (result);
}
/*
* tcl_LogGet --
*
* PUBLIC: int tcl_LogGet __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogGet(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
COMPQUIET(objv, NULL);
COMPQUIET(objc, 0);
COMPQUIET(dbenv, NULL);
Tcl_SetResult(interp, "FAIL: log_get deprecated\n", TCL_STATIC);
return (TCL_ERROR);
}
/*
* tcl_LogPut --
*
* PUBLIC: int tcl_LogPut __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogPut(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
static const char *logputopts[] = {
"-flush",
NULL
};
enum logputopts {
LOGPUT_FLUSH
};
DB_LSN lsn;
DBT data;
Tcl_Obj *intobj, *res;
void *dtmp;
u_int32_t flag;
int freedata, optindex, result, ret;
result = TCL_OK;
flag = 0;
freedata = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? record");
return (TCL_ERROR);
}
/*
* Data/record must be the last arg.
*/
memset(&data, 0, sizeof(data));
ret = _CopyObjBytes(interp, objv[objc-1], &dtmp,
&data.size, &freedata);
if (ret != 0) {
result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "log put");
return (result);
}
data.data = dtmp;
/*
* Get the command name index from the object based on the options
* defined above.
*/
if (objc == 4) {
if (Tcl_GetIndexFromObj(interp, objv[2],
logputopts, "option", TCL_EXACT, &optindex) != TCL_OK) {
return (IS_HELP(objv[2]));
}
switch ((enum logputopts)optindex) {
case LOGPUT_FLUSH:
flag = DB_FLUSH;
break;
}
}
if (result == TCL_ERROR)
return (result);
_debug_check();
ret = dbenv->log_put(dbenv, &lsn, &data, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log_put");
if (result == TCL_ERROR)
return (result);
res = Tcl_NewListObj(0, NULL);
intobj = Tcl_NewWideIntObj((Tcl_WideInt)lsn.file);
result = Tcl_ListObjAppendElement(interp, res, intobj);
intobj = Tcl_NewWideIntObj((Tcl_WideInt)lsn.offset);
result = Tcl_ListObjAppendElement(interp, res, intobj);
Tcl_SetObjResult(interp, res);
if (freedata)
__os_free(NULL, dtmp);
return (result);
}
/*
* tcl_LogStat --
*
* PUBLIC: int tcl_LogStat __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_LogStat(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_LOG_STAT *sp;
Tcl_Obj *res;
int result, ret;
result = TCL_OK;
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->log_stat(dbenv, &sp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log stat");
if (result == TCL_ERROR)
return (result);
/*
* Have our stats, now construct the name value
* list pairs and free up the memory.
*/
res = Tcl_NewObj();
/*
* MAKE_STAT_LIST assumes 'res' and 'error' label.
*/
#ifdef HAVE_STATISTICS
MAKE_STAT_LIST("Magic", sp->st_magic);
MAKE_STAT_LIST("Log file Version", sp->st_version);
MAKE_STAT_LIST("Region size", sp->st_regsize);
MAKE_STAT_LIST("Log file mode", sp->st_mode);
MAKE_STAT_LIST("Log record cache size", sp->st_lg_bsize);
MAKE_STAT_LIST("Current log file size", sp->st_lg_size);
MAKE_STAT_LIST("Log file records written", sp->st_record);
MAKE_STAT_LIST("Mbytes written", sp->st_w_mbytes);
MAKE_STAT_LIST("Bytes written (over Mb)", sp->st_w_bytes);
MAKE_STAT_LIST("Mbytes written since checkpoint", sp->st_wc_mbytes);
MAKE_STAT_LIST("Bytes written (over Mb) since checkpoint",
sp->st_wc_bytes);
MAKE_STAT_LIST("Times log written", sp->st_wcount);
MAKE_STAT_LIST("Times log written because cache filled up",
sp->st_wcount_fill);
MAKE_STAT_LIST("Times log read from disk", sp->st_rcount);
MAKE_STAT_LIST("Times log flushed to disk", sp->st_scount);
MAKE_STAT_LIST("Current log file number", sp->st_cur_file);
MAKE_STAT_LIST("Current log file offset", sp->st_cur_offset);
MAKE_STAT_LIST("On-disk log file number", sp->st_disk_file);
MAKE_STAT_LIST("On-disk log file offset", sp->st_disk_offset);
MAKE_STAT_LIST("Max commits in a log flush", sp->st_maxcommitperflush);
MAKE_STAT_LIST("Min commits in a log flush", sp->st_mincommitperflush);
MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
#endif
Tcl_SetObjResult(interp, res);
error:
__os_ufree(dbenv->env, sp);
return (result);
}
/*
* logc_Cmd --
* Implements the log cursor command.
*
* PUBLIC: int logc_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
*/
int
logc_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Cursor handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *logccmds[] = {
"close",
"get",
"version",
NULL
};
enum logccmds {
LOGCCLOSE,
LOGCGET,
LOGCVERSION
};
DB_LOGC *logc;
DBTCL_INFO *logcip;
Tcl_Obj *res;
u_int32_t version;
int cmdindex, result, ret;
Tcl_ResetResult(interp);
logc = (DB_LOGC *)clientData;
logcip = _PtrToInfo((void *)logc);
result = TCL_OK;
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
return (TCL_ERROR);
}
if (logc == NULL) {
Tcl_SetResult(interp, "NULL logc pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (logcip == NULL) {
Tcl_SetResult(interp, "NULL logc info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the berkdbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], logccmds, "command",
TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
switch ((enum logccmds)cmdindex) {
case LOGCCLOSE:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = logc->close(logc, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"logc close");
if (result == TCL_OK) {
(void)Tcl_DeleteCommand(interp, logcip->i_name);
_DeleteInfo(logcip);
}
break;
case LOGCGET:
result = tcl_LogcGet(interp, objc, objv, logc);
break;
case LOGCVERSION:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = logc->version(logc, &version, 0);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"logc version")) == TCL_OK) {
res = Tcl_NewIntObj((int)version);
Tcl_SetObjResult(interp, res);
}
break;
}
return (result);
}
static int
tcl_LogcGet(interp, objc, objv, logc)
Tcl_Interp *interp;
int objc;
Tcl_Obj * CONST *objv;
DB_LOGC *logc;
{
static const char *logcgetopts[] = {
"-current",
"-first",
"-last",
"-next",
"-prev",
"-set",
NULL
};
enum logcgetopts {
LOGCGET_CURRENT,
LOGCGET_FIRST,
LOGCGET_LAST,
LOGCGET_NEXT,
LOGCGET_PREV,
LOGCGET_SET
};
DB_LSN lsn;
DBT data;
Tcl_Obj *dataobj, *lsnlist, *myobjv[2], *res;
u_int32_t flag;
int i, myobjc, optindex, result, ret;
result = TCL_OK;
res = NULL;
flag = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? lsn");
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
logcgetopts, "option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[i]));
i++;
switch ((enum logcgetopts)optindex) {
case LOGCGET_CURRENT:
FLAG_CHECK(flag);
flag |= DB_CURRENT;
break;
case LOGCGET_FIRST:
FLAG_CHECK(flag);
flag |= DB_FIRST;
break;
case LOGCGET_LAST:
FLAG_CHECK(flag);
flag |= DB_LAST;
break;
case LOGCGET_NEXT:
FLAG_CHECK(flag);
flag |= DB_NEXT;
break;
case LOGCGET_PREV:
FLAG_CHECK(flag);
flag |= DB_PREV;
break;
case LOGCGET_SET:
FLAG_CHECK(flag);
flag |= DB_SET;
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv, "?-set lsn?");
result = TCL_ERROR;
break;
}
result = _GetLsn(interp, objv[i++], &lsn);
break;
}
}
if (result == TCL_ERROR)
return (result);
memset(&data, 0, sizeof(data));
_debug_check();
ret = logc->get(logc, &lsn, &data, flag);
res = Tcl_NewListObj(0, NULL);
if (res == NULL)
goto memerr;
if (ret == 0) {
/*
* Success. Set up return list as {LSN data} where LSN
* is a sublist {file offset}.
*/
myobjc = 2;
myobjv[0] = Tcl_NewWideIntObj((Tcl_WideInt)lsn.file);
myobjv[1] = Tcl_NewWideIntObj((Tcl_WideInt)lsn.offset);
lsnlist = Tcl_NewListObj(myobjc, myobjv);
if (lsnlist == NULL)
goto memerr;
result = Tcl_ListObjAppendElement(interp, res, lsnlist);
dataobj = NewStringObj(data.data, data.size);
if (dataobj == NULL) {
goto memerr;
}
result = Tcl_ListObjAppendElement(interp, res, dataobj);
} else
result = _ReturnSetup(interp, ret, DB_RETOK_LGGET(ret),
"DB_LOGC->get");
Tcl_SetObjResult(interp, res);
if (0) {
memerr: if (res != NULL) {
Tcl_DecrRefCount(res);
}
Tcl_SetResult(interp, "allocation failed", TCL_STATIC);
}
return (result);
}
static const char *confwhich[] = {
"autoremove",
"direct",
"dsync",
"inmemory",
"zero",
NULL
};
enum logwhich {
LOGCONF_AUTO,
LOGCONF_DIRECT,
LOGCONF_DSYNC,
LOGCONF_INMEMORY,
LOGCONF_ZERO
};
/*
* tcl_LogConfig --
* Call DB_ENV->rep_set_config().
*
* PUBLIC: int tcl_LogConfig
* PUBLIC: __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *));
*/
int
tcl_LogConfig(interp, dbenv, list)
Tcl_Interp *interp; /* Interpreter */
DB_ENV *dbenv; /* Environment pointer */
Tcl_Obj *list; /* {which on|off} */
{
static const char *confonoff[] = {
"off",
"on",
NULL
};
enum confonoff {
LOGCONF_OFF,
LOGCONF_ON
};
Tcl_Obj **myobjv, *onoff, *which;
int myobjc, on, optindex, result, ret;
u_int32_t wh;
result = Tcl_ListObjGetElements(interp, list, &myobjc, &myobjv);
if (myobjc != 2)
Tcl_WrongNumArgs(interp, 2, myobjv, "?{which onoff}?");
which = myobjv[0];
onoff = myobjv[1];
if (result != TCL_OK)
return (result);
if (Tcl_GetIndexFromObj(interp, which, confwhich, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(which));
switch ((enum logwhich)optindex) {
case LOGCONF_AUTO:
wh = DB_LOG_AUTO_REMOVE;
break;
case LOGCONF_DIRECT:
wh = DB_LOG_DIRECT;
break;
case LOGCONF_DSYNC:
wh = DB_LOG_DSYNC;
break;
case LOGCONF_INMEMORY:
wh = DB_LOG_IN_MEMORY;
break;
case LOGCONF_ZERO:
wh = DB_LOG_ZERO;
break;
default:
return (TCL_ERROR);
}
if (Tcl_GetIndexFromObj(interp, onoff, confonoff, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(onoff));
switch ((enum confonoff)optindex) {
case LOGCONF_OFF:
on = 0;
break;
case LOGCONF_ON:
on = 1;
break;
default:
return (TCL_ERROR);
}
ret = dbenv->log_set_config(dbenv, wh, on);
return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"env rep_config"));
}
/*
* tcl_LogGetConfig --
* Call DB_ENV->rep_get_config().
*
* PUBLIC: int tcl_LogGetConfig
* PUBLIC: __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *));
*/
int
tcl_LogGetConfig(interp, dbenv, which)
Tcl_Interp *interp; /* Interpreter */
DB_ENV *dbenv; /* Environment pointer */
Tcl_Obj *which; /* which flag */
{
Tcl_Obj *res;
int on, optindex, result, ret;
u_int32_t wh;
if (Tcl_GetIndexFromObj(interp, which, confwhich, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(which));
res = NULL;
switch ((enum logwhich)optindex) {
case LOGCONF_AUTO:
wh = DB_LOG_AUTO_REMOVE;
break;
case LOGCONF_DIRECT:
wh = DB_LOG_DIRECT;
break;
case LOGCONF_DSYNC:
wh = DB_LOG_DSYNC;
break;
case LOGCONF_INMEMORY:
wh = DB_LOG_IN_MEMORY;
break;
case LOGCONF_ZERO:
wh = DB_LOG_ZERO;
break;
default:
return (TCL_ERROR);
}
ret = dbenv->log_get_config(dbenv, wh, &on);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"env log_config")) == TCL_OK) {
res = Tcl_NewIntObj(on);
Tcl_SetObjResult(interp, res);
}
return (result);
}
#endif

941
tcl/tcl_mp.c Normal file
View File

@@ -0,0 +1,941 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_mp.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
/*
* Prototypes for procedures defined later in this file:
*/
#ifdef CONFIG_TEST
static int mp_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
static int pg_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
static int tcl_MpGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
DB_MPOOLFILE *, DBTCL_INFO *));
static int tcl_Pg __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
void *, DB_MPOOLFILE *, DBTCL_INFO *));
static int tcl_PgInit __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
void *, DBTCL_INFO *));
static int tcl_PgIsset __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
void *, DBTCL_INFO *));
#endif
/*
* _MpInfoDelete --
* Removes "sub" mp page info structures that are children
* of this mp.
*
* PUBLIC: void _MpInfoDelete __P((Tcl_Interp *, DBTCL_INFO *));
*/
void
_MpInfoDelete(interp, mpip)
Tcl_Interp *interp; /* Interpreter */
DBTCL_INFO *mpip; /* Info for mp */
{
DBTCL_INFO *nextp, *p;
for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
/*
* Check if this info structure "belongs" to this
* mp. Remove its commands and info structure.
*/
nextp = LIST_NEXT(p, entries);
if (p->i_parent == mpip && p->i_type == I_PG) {
(void)Tcl_DeleteCommand(interp, p->i_name);
_DeleteInfo(p);
}
}
}
#ifdef CONFIG_TEST
/*
* tcl_MpSync --
*
* PUBLIC: int tcl_MpSync __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_MpSync(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_LSN lsn, *lsnp;
int result, ret;
result = TCL_OK;
lsnp = NULL;
/*
* No flags, must be 3 args.
*/
if (objc == 3) {
result = _GetLsn(interp, objv[2], &lsn);
if (result == TCL_ERROR)
return (result);
lsnp = &lsn;
}
else if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, "lsn");
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->memp_sync(dbenv, lsnp);
return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp sync"));
}
/*
* tcl_MpTrickle --
*
* PUBLIC: int tcl_MpTrickle __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_MpTrickle(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
Tcl_Obj *res;
int pages, percent, result, ret;
result = TCL_OK;
/*
* No flags, must be 3 args.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "percent");
return (TCL_ERROR);
}
result = Tcl_GetIntFromObj(interp, objv[2], &percent);
if (result == TCL_ERROR)
return (result);
_debug_check();
ret = dbenv->memp_trickle(dbenv, percent, &pages);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp trickle");
if (result == TCL_ERROR)
return (result);
res = Tcl_NewIntObj(pages);
Tcl_SetObjResult(interp, res);
return (result);
}
/*
* tcl_Mp --
*
* PUBLIC: int tcl_Mp __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *, DBTCL_INFO *));
*/
int
tcl_Mp(interp, objc, objv, dbenv, envip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
DBTCL_INFO *envip; /* Info pointer */
{
static const char *mpopts[] = {
"-create",
"-mode",
"-multiversion",
"-nommap",
"-pagesize",
"-rdonly",
NULL
};
enum mpopts {
MPCREATE,
MPMODE,
MPMULTIVERSION,
MPNOMMAP,
MPPAGE,
MPRDONLY
};
DBTCL_INFO *ip;
DB_MPOOLFILE *mpf;
Tcl_Obj *res;
u_int32_t flag;
int i, pgsize, mode, optindex, result, ret;
char *file, newname[MSG_SIZE];
result = TCL_OK;
i = 2;
flag = 0;
mode = 0;
pgsize = 0;
memset(newname, 0, MSG_SIZE);
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
mpopts, "option", TCL_EXACT, &optindex) != TCL_OK) {
/*
* Reset the result so we don't get an errant
* error message if there is another error.
* This arg is the file name.
*/
if (IS_HELP(objv[i]) == TCL_OK)
return (TCL_OK);
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum mpopts)optindex) {
case MPCREATE:
flag |= DB_CREATE;
break;
case MPMODE:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-mode mode?");
result = TCL_ERROR;
break;
}
/*
* Don't need to check result here because
* if TCL_ERROR, the error message is already
* set up, and we'll bail out below. If ok,
* the mode is set and we go on.
*/
result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
break;
case MPMULTIVERSION:
flag |= DB_MULTIVERSION;
break;
case MPNOMMAP:
flag |= DB_NOMMAP;
break;
case MPPAGE:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-pagesize size?");
result = TCL_ERROR;
break;
}
/*
* Don't need to check result here because
* if TCL_ERROR, the error message is already
* set up, and we'll bail out below. If ok,
* the mode is set and we go on.
*/
result = Tcl_GetIntFromObj(interp, objv[i++], &pgsize);
break;
case MPRDONLY:
flag |= DB_RDONLY;
break;
}
if (result != TCL_OK)
goto error;
}
/*
* Any left over arg is a file name. It better be the last arg.
*/
file = NULL;
if (i != objc) {
if (i != objc - 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
result = TCL_ERROR;
goto error;
}
file = Tcl_GetStringFromObj(objv[i++], NULL);
}
snprintf(newname, sizeof(newname), "%s.mp%d",
envip->i_name, envip->i_envmpid);
ip = _NewInfo(interp, NULL, newname, I_MP);
if (ip == NULL) {
Tcl_SetResult(interp, "Could not set up info",
TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
if ((ret = dbenv->memp_fcreate(dbenv, &mpf, 0)) != 0) {
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mpool");
_DeleteInfo(ip);
goto error;
}
/*
* XXX
* Interface doesn't currently support DB_MPOOLFILE configuration.
*/
if ((ret = mpf->open(mpf, file, flag, mode, (size_t)pgsize)) != 0) {
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mpool");
_DeleteInfo(ip);
(void)mpf->close(mpf, 0);
goto error;
}
/*
* Success. Set up return. Set up new info and command widget for
* this mpool.
*/
envip->i_envmpid++;
ip->i_parent = envip;
ip->i_pgsz = pgsize;
_SetInfoData(ip, mpf);
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)mp_Cmd, (ClientData)mpf, NULL);
res = NewStringObj(newname, strlen(newname));
Tcl_SetObjResult(interp, res);
error:
return (result);
}
/*
* tcl_MpStat --
*
* PUBLIC: int tcl_MpStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_MpStat(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DB_MPOOL_FSTAT **fsp, **savefsp;
DB_MPOOL_STAT *sp;
int result;
int ret;
Tcl_Obj *res;
Tcl_Obj *res1;
result = TCL_OK;
savefsp = NULL;
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->memp_stat(dbenv, &sp, &fsp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp stat");
if (result == TCL_ERROR)
return (result);
/*
* Have our stats, now construct the name value
* list pairs and free up the memory.
*/
res = Tcl_NewObj();
#ifdef HAVE_STATISTICS
/*
* MAKE_STAT_LIST assumes 'res' and 'error' label.
*/
MAKE_STAT_LIST("Cache size (gbytes)", sp->st_gbytes);
MAKE_STAT_LIST("Cache size (bytes)", sp->st_bytes);
MAKE_STAT_LIST("Number of caches", sp->st_ncache);
MAKE_STAT_LIST("Maximum number of caches", sp->st_max_ncache);
MAKE_STAT_LIST("Region size", sp->st_regsize);
MAKE_STAT_LIST("Maximum memory-mapped file size", sp->st_mmapsize);
MAKE_STAT_LIST("Maximum open file descriptors", sp->st_maxopenfd);
MAKE_STAT_LIST("Maximum sequential buffer writes", sp->st_maxwrite);
MAKE_STAT_LIST(
"Sleep after writing maximum buffers", sp->st_maxwrite_sleep);
MAKE_STAT_LIST("Pages mapped into address space", sp->st_map);
MAKE_STAT_LIST("Cache hits", sp->st_cache_hit);
MAKE_STAT_LIST("Cache misses", sp->st_cache_miss);
MAKE_STAT_LIST("Pages created", sp->st_page_create);
MAKE_STAT_LIST("Pages read in", sp->st_page_in);
MAKE_STAT_LIST("Pages written", sp->st_page_out);
MAKE_STAT_LIST("Clean page evictions", sp->st_ro_evict);
MAKE_STAT_LIST("Dirty page evictions", sp->st_rw_evict);
MAKE_STAT_LIST("Dirty pages trickled", sp->st_page_trickle);
MAKE_STAT_LIST("Cached pages", sp->st_pages);
MAKE_STAT_LIST("Cached clean pages", sp->st_page_clean);
MAKE_STAT_LIST("Cached dirty pages", sp->st_page_dirty);
MAKE_STAT_LIST("Hash buckets", sp->st_hash_buckets);
MAKE_STAT_LIST("Hash lookups", sp->st_hash_searches);
MAKE_STAT_LIST("Longest hash chain found", sp->st_hash_longest);
MAKE_STAT_LIST("Hash elements examined", sp->st_hash_examined);
MAKE_STAT_LIST("Number of hash bucket nowaits", sp->st_hash_nowait);
MAKE_STAT_LIST("Number of hash bucket waits", sp->st_hash_wait);
MAKE_STAT_LIST("Maximum number of hash bucket nowaits",
sp->st_hash_max_nowait);
MAKE_STAT_LIST("Maximum number of hash bucket waits",
sp->st_hash_max_wait);
MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
MAKE_STAT_LIST("Buffers frozen", sp->st_mvcc_frozen);
MAKE_STAT_LIST("Buffers thawed", sp->st_mvcc_thawed);
MAKE_STAT_LIST("Frozen buffers freed", sp->st_mvcc_freed);
MAKE_STAT_LIST("Page allocations", sp->st_alloc);
MAKE_STAT_LIST("Buckets examined during allocation",
sp->st_alloc_buckets);
MAKE_STAT_LIST("Maximum buckets examined during allocation",
sp->st_alloc_max_buckets);
MAKE_STAT_LIST("Pages examined during allocation", sp->st_alloc_pages);
MAKE_STAT_LIST("Maximum pages examined during allocation",
sp->st_alloc_max_pages);
MAKE_STAT_LIST("Threads waiting on buffer I/O", sp->st_io_wait);
/*
* Save global stat list as res1. The MAKE_STAT_LIST
* macro assumes 'res' so we'll use that to build up
* our per-file sublist.
*/
res1 = res;
for (savefsp = fsp; fsp != NULL && *fsp != NULL; fsp++) {
res = Tcl_NewObj();
result = _SetListElem(interp, res, "File Name",
strlen("File Name"), (*fsp)->file_name,
strlen((*fsp)->file_name));
if (result != TCL_OK)
goto error;
MAKE_STAT_LIST("Page size", (*fsp)->st_pagesize);
MAKE_STAT_LIST("Pages mapped into address space",
(*fsp)->st_map);
MAKE_STAT_LIST("Cache hits", (*fsp)->st_cache_hit);
MAKE_STAT_LIST("Cache misses", (*fsp)->st_cache_miss);
MAKE_STAT_LIST("Pages created", (*fsp)->st_page_create);
MAKE_STAT_LIST("Pages read in", (*fsp)->st_page_in);
MAKE_STAT_LIST("Pages written", (*fsp)->st_page_out);
/*
* Now that we have a complete "per-file" stat list, append
* that to the other list.
*/
result = Tcl_ListObjAppendElement(interp, res1, res);
if (result != TCL_OK)
goto error;
}
#endif
Tcl_SetObjResult(interp, res1);
error:
__os_ufree(dbenv->env, sp);
if (savefsp != NULL)
__os_ufree(dbenv->env, savefsp);
return (result);
}
/*
* mp_Cmd --
* Implements the "mp" widget.
*/
static int
mp_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Mp handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *mpcmds[] = {
"close",
"fsync",
"get",
"get_clear_len",
"get_fileid",
"get_ftype",
"get_lsn_offset",
"get_pgcookie",
NULL
};
enum mpcmds {
MPCLOSE,
MPFSYNC,
MPGET,
MPGETCLEARLEN,
MPGETFILEID,
MPGETFTYPE,
MPGETLSNOFFSET,
MPGETPGCOOKIE
};
DB_MPOOLFILE *mp;
int cmdindex, ftype, length, result, ret;
DBTCL_INFO *mpip;
Tcl_Obj *res;
char *obj_name;
u_int32_t value;
int32_t intval;
u_int8_t fileid[DB_FILE_ID_LEN];
DBT cookie;
Tcl_ResetResult(interp);
mp = (DB_MPOOLFILE *)clientData;
obj_name = Tcl_GetStringFromObj(objv[0], &length);
mpip = _NameToInfo(obj_name);
result = TCL_OK;
if (mp == NULL) {
Tcl_SetResult(interp, "NULL mp pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (mpip == NULL) {
Tcl_SetResult(interp, "NULL mp info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], mpcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum mpcmds)cmdindex) {
case MPCLOSE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = mp->close(mp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp close");
_MpInfoDelete(interp, mpip);
(void)Tcl_DeleteCommand(interp, mpip->i_name);
_DeleteInfo(mpip);
break;
case MPFSYNC:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = mp->sync(mp);
res = Tcl_NewIntObj(ret);
break;
case MPGET:
result = tcl_MpGet(interp, objc, objv, mp, mpip);
break;
case MPGETCLEARLEN:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = mp->get_clear_len(mp, &value);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp get_clear_len")) == TCL_OK)
res = Tcl_NewIntObj((int)value);
break;
case MPGETFILEID:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = mp->get_fileid(mp, fileid);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp get_fileid")) == TCL_OK)
res = NewStringObj((char *)fileid, DB_FILE_ID_LEN);
break;
case MPGETFTYPE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = mp->get_ftype(mp, &ftype);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp get_ftype")) == TCL_OK)
res = Tcl_NewIntObj(ftype);
break;
case MPGETLSNOFFSET:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = mp->get_lsn_offset(mp, &intval);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp get_lsn_offset")) == TCL_OK)
res = Tcl_NewIntObj(intval);
break;
case MPGETPGCOOKIE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
memset(&cookie, 0, sizeof(DBT));
ret = mp->get_pgcookie(mp, &cookie);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"mp get_pgcookie")) == TCL_OK)
res = Tcl_NewByteArrayObj((u_char *)cookie.data,
(int)cookie.size);
break;
}
/*
* Only set result if we have a res. Otherwise, lower
* functions have already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}
/*
* tcl_MpGet --
*/
static int
tcl_MpGet(interp, objc, objv, mp, mpip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_MPOOLFILE *mp; /* mp pointer */
DBTCL_INFO *mpip; /* mp info pointer */
{
static const char *mpget[] = {
"-create",
"-dirty",
"-last",
"-new",
"-txn",
NULL
};
enum mpget {
MPGET_CREATE,
MPGET_DIRTY,
MPGET_LAST,
MPGET_NEW,
MPGET_TXN
};
DBTCL_INFO *ip;
Tcl_Obj *res;
DB_TXN *txn;
db_pgno_t pgno;
u_int32_t flag;
int i, ipgno, optindex, result, ret;
char *arg, msg[MSG_SIZE], newname[MSG_SIZE];
void *page;
txn = NULL;
result = TCL_OK;
memset(newname, 0, MSG_SIZE);
i = 2;
flag = 0;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
mpget, "option", TCL_EXACT, &optindex) != TCL_OK) {
/*
* Reset the result so we don't get an errant
* error message if there is another error.
* This arg is the page number.
*/
if (IS_HELP(objv[i]) == TCL_OK)
return (TCL_OK);
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum mpget)optindex) {
case MPGET_CREATE:
flag |= DB_MPOOL_CREATE;
break;
case MPGET_DIRTY:
flag |= DB_MPOOL_DIRTY;
break;
case MPGET_LAST:
flag |= DB_MPOOL_LAST;
break;
case MPGET_NEW:
flag |= DB_MPOOL_NEW;
break;
case MPGET_TXN:
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
result = TCL_ERROR;
break;
}
arg = Tcl_GetStringFromObj(objv[i++], NULL);
txn = NAME_TO_TXN(arg);
if (txn == NULL) {
snprintf(msg, MSG_SIZE,
"mpool get: Invalid txn: %s\n", arg);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
result = TCL_ERROR;
}
break;
}
if (result != TCL_OK)
goto error;
}
/*
* Any left over arg is a page number. It better be the last arg.
*/
ipgno = 0;
if (i != objc) {
if (i != objc - 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?args? ?pgno?");
result = TCL_ERROR;
goto error;
}
result = Tcl_GetIntFromObj(interp, objv[i++], &ipgno);
if (result != TCL_OK)
goto error;
}
snprintf(newname, sizeof(newname), "%s.pg%d",
mpip->i_name, mpip->i_mppgid);
ip = _NewInfo(interp, NULL, newname, I_PG);
if (ip == NULL) {
Tcl_SetResult(interp, "Could not set up info",
TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
pgno = (db_pgno_t)ipgno;
ret = mp->get(mp, &pgno, NULL, flag, &page);
result = _ReturnSetup(interp, ret, DB_RETOK_MPGET(ret), "mpool get");
if (result == TCL_ERROR)
_DeleteInfo(ip);
else {
/*
* Success. Set up return. Set up new info
* and command widget for this mpool.
*/
mpip->i_mppgid++;
ip->i_parent = mpip;
ip->i_pgno = pgno;
ip->i_pgsz = mpip->i_pgsz;
_SetInfoData(ip, page);
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)pg_Cmd, (ClientData)page, NULL);
res = NewStringObj(newname, strlen(newname));
Tcl_SetObjResult(interp, res);
}
error:
return (result);
}
/*
* pg_Cmd --
* Implements the "pg" widget.
*/
static int
pg_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Page handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *pgcmds[] = {
"init",
"is_setto",
"pgnum",
"pgsize",
"put",
NULL
};
enum pgcmds {
PGINIT,
PGISSET,
PGNUM,
PGSIZE,
PGPUT
};
DB_MPOOLFILE *mp;
int cmdindex, length, result;
char *obj_name;
void *page;
DBTCL_INFO *pgip;
Tcl_Obj *res;
Tcl_ResetResult(interp);
page = (void *)clientData;
obj_name = Tcl_GetStringFromObj(objv[0], &length);
pgip = _NameToInfo(obj_name);
mp = NAME_TO_MP(pgip->i_parent->i_name);
result = TCL_OK;
if (page == NULL) {
Tcl_SetResult(interp, "NULL page pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (mp == NULL) {
Tcl_SetResult(interp, "NULL mp pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (pgip == NULL) {
Tcl_SetResult(interp, "NULL page info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], pgcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum pgcmds)cmdindex) {
case PGNUM:
res = Tcl_NewWideIntObj((Tcl_WideInt)pgip->i_pgno);
break;
case PGSIZE:
res = Tcl_NewWideIntObj((Tcl_WideInt)pgip->i_pgsz);
break;
case PGPUT:
result = tcl_Pg(interp, objc, objv, page, mp, pgip);
break;
case PGINIT:
result = tcl_PgInit(interp, objc, objv, page, pgip);
break;
case PGISSET:
result = tcl_PgIsset(interp, objc, objv, page, pgip);
break;
}
/*
* Only set result if we have a res. Otherwise, lower
* functions have already done so.
*/
if (result == TCL_OK && res != NULL)
Tcl_SetObjResult(interp, res);
return (result);
}
static int
tcl_Pg(interp, objc, objv, page, mp, pgip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
void *page; /* Page pointer */
DB_MPOOLFILE *mp; /* Mpool pointer */
DBTCL_INFO *pgip; /* Info pointer */
{
static const char *pgopt[] = {
"-discard",
NULL
};
enum pgopt {
PGDISCARD
};
u_int32_t flag;
int i, optindex, result, ret;
result = TCL_OK;
i = 2;
flag = 0;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
pgopt, "option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[i]));
i++;
switch ((enum pgopt)optindex) {
case PGDISCARD:
flag |= DB_MPOOL_DISCARD;
break;
}
}
_debug_check();
ret = mp->put(mp, page, DB_PRIORITY_UNCHANGED, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "page");
(void)Tcl_DeleteCommand(interp, pgip->i_name);
_DeleteInfo(pgip);
return (result);
}
static int
tcl_PgInit(interp, objc, objv, page, pgip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
void *page; /* Page pointer */
DBTCL_INFO *pgip; /* Info pointer */
{
Tcl_Obj *res;
long *p, *endp, newval;
int length, pgsz, result;
u_char *s;
result = TCL_OK;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "val");
return (TCL_ERROR);
}
pgsz = pgip->i_pgsz;
result = Tcl_GetLongFromObj(interp, objv[2], &newval);
if (result != TCL_OK) {
s = Tcl_GetByteArrayFromObj(objv[2], &length);
if (s == NULL)
return (TCL_ERROR);
memcpy(page, s, (size_t)((length < pgsz) ? length : pgsz));
result = TCL_OK;
} else {
p = (long *)page;
for (endp = p + ((u_int)pgsz / sizeof(long)); p < endp; p++)
*p = newval;
}
res = Tcl_NewIntObj(0);
Tcl_SetObjResult(interp, res);
return (result);
}
static int
tcl_PgIsset(interp, objc, objv, page, pgip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
void *page; /* Page pointer */
DBTCL_INFO *pgip; /* Info pointer */
{
Tcl_Obj *res;
long *p, *endp, newval;
int length, pgsz, result;
u_char *s;
result = TCL_OK;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "val");
return (TCL_ERROR);
}
pgsz = pgip->i_pgsz;
result = Tcl_GetLongFromObj(interp, objv[2], &newval);
if (result != TCL_OK) {
if ((s = Tcl_GetByteArrayFromObj(objv[2], &length)) == NULL)
return (TCL_ERROR);
result = TCL_OK;
if (memcmp(page, s,
(size_t)((length < pgsz) ? length : pgsz)) != 0) {
res = Tcl_NewIntObj(0);
Tcl_SetObjResult(interp, res);
return (result);
}
} else {
p = (long *)page;
/*
* If any value is not the same, return 0 (is not set to
* this value). Otherwise, if we finish the loop, we return 1
* (is set to this value).
*/
for (endp = p + ((u_int)pgsz / sizeof(long)); p < endp; p++)
if (*p != newval) {
res = Tcl_NewIntObj(0);
Tcl_SetObjResult(interp, res);
return (result);
}
}
res = Tcl_NewIntObj(1);
Tcl_SetObjResult(interp, res);
return (result);
}
#endif

1322
tcl/tcl_rep.c Normal file
View File

File diff suppressed because it is too large Load Diff

511
tcl/tcl_seq.c Normal file
View File

@@ -0,0 +1,511 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 2004,2008 Oracle. All rights reserved.
*
* $Id: tcl_seq.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#ifdef HAVE_64BIT_TYPES
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
#include "dbinc_auto/sequence_ext.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int tcl_SeqClose __P((Tcl_Interp *,
int, Tcl_Obj * CONST*, DB_SEQUENCE *, DBTCL_INFO *));
static int tcl_SeqGet __P((Tcl_Interp *,
int, Tcl_Obj * CONST*, DB_SEQUENCE *));
static int tcl_SeqRemove __P((Tcl_Interp *,
int, Tcl_Obj * CONST*, DB_SEQUENCE *, DBTCL_INFO *));
static int tcl_SeqStat __P((Tcl_Interp *,
int, Tcl_Obj * CONST*, DB_SEQUENCE *));
static int tcl_SeqGetFlags __P((Tcl_Interp *,
int, Tcl_Obj * CONST*, DB_SEQUENCE *));
/*
*
* PUBLIC: int seq_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
*
* seq_Cmd --
* Implements the "seq" widget.
*/
int
seq_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* SEQ handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *seqcmds[] = {
"close",
"get",
"get_cachesize",
"get_db",
"get_flags",
"get_key",
"get_range",
"remove",
"stat",
NULL
};
enum seqcmds {
SEQCLOSE,
SEQGET,
SEQGETCACHESIZE,
SEQGETDB,
SEQGETFLAGS,
SEQGETKEY,
SEQGETRANGE,
SEQREMOVE,
SEQSTAT
};
DB *dbp;
DBT key;
DBTCL_INFO *dbip, *ip;
DB_SEQUENCE *seq;
Tcl_Obj *myobjv[2], *res;
db_seq_t min, max;
int cmdindex, ncache, result, ret;
Tcl_ResetResult(interp);
seq = (DB_SEQUENCE *)clientData;
result = TCL_OK;
dbip = NULL;
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
return (TCL_ERROR);
}
if (seq == NULL) {
Tcl_SetResult(interp, "NULL sequence pointer", TCL_STATIC);
return (TCL_ERROR);
}
ip = _PtrToInfo((void *)seq);
if (ip == NULL) {
Tcl_SetResult(interp, "NULL info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], seqcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum seqcmds)cmdindex) {
case SEQGETRANGE:
ret = seq->get_range(seq, &min, &max);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"sequence get_range")) == TCL_OK) {
myobjv[0] = Tcl_NewWideIntObj(min);
myobjv[1] = Tcl_NewWideIntObj(max);
res = Tcl_NewListObj(2, myobjv);
}
break;
case SEQCLOSE:
result = tcl_SeqClose(interp, objc, objv, seq, ip);
break;
case SEQREMOVE:
result = tcl_SeqRemove(interp, objc, objv, seq, ip);
break;
case SEQGET:
result = tcl_SeqGet(interp, objc, objv, seq);
break;
case SEQSTAT:
result = tcl_SeqStat(interp, objc, objv, seq);
break;
case SEQGETCACHESIZE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = seq->get_cachesize(seq, &ncache);
if ((result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "sequence get_cachesize")) == TCL_OK)
res = Tcl_NewIntObj(ncache);
break;
case SEQGETDB:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = seq->get_db(seq, &dbp);
if (ret == 0 && (dbip = _PtrToInfo((void *)dbp)) == NULL) {
Tcl_SetResult(interp,
"NULL db info pointer", TCL_STATIC);
return (TCL_ERROR);
}
if ((result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "sequence get_db")) == TCL_OK)
res = NewStringObj(dbip->i_name, strlen(dbip->i_name));
break;
case SEQGETKEY:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = seq->get_key(seq, &key);
if ((result = _ReturnSetup(interp, ret,
DB_RETOK_STD(ret), "sequence get_key")) == TCL_OK)
res = Tcl_NewByteArrayObj(
(u_char *)key.data, (int)key.size);
break;
case SEQGETFLAGS:
result = tcl_SeqGetFlags(interp, objc, objv, seq);
break;
}
/*
* Only set result if we have a res. Otherwise, lower functions have
* already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}
/*
* tcl_db_stat --
*/
static int
tcl_SeqStat(interp, objc, objv, seq)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_SEQUENCE *seq; /* Database pointer */
{
DB_SEQUENCE_STAT *sp;
u_int32_t flag;
Tcl_Obj *res, *flaglist, *myobjv[2];
int result, ret;
char *arg;
result = TCL_OK;
flag = 0;
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?-clear?");
return (TCL_ERROR);
}
if (objc == 3) {
arg = Tcl_GetStringFromObj(objv[2], NULL);
if (strcmp(arg, "-clear") == 0)
flag = DB_STAT_CLEAR;
else {
Tcl_SetResult(interp,
"db stat: unknown arg", TCL_STATIC);
return (TCL_ERROR);
}
}
_debug_check();
ret = seq->stat(seq, &sp, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db stat");
if (result == TCL_ERROR)
return (result);
res = Tcl_NewObj();
MAKE_STAT_LIST("Wait", sp->st_wait);
MAKE_STAT_LIST("No wait", sp->st_nowait);
MAKE_WSTAT_LIST("Current", sp->st_current);
MAKE_WSTAT_LIST("Cached", sp->st_value);
MAKE_WSTAT_LIST("Max Cached", sp->st_last_value);
MAKE_WSTAT_LIST("Min", sp->st_min);
MAKE_WSTAT_LIST("Max", sp->st_max);
MAKE_STAT_LIST("Cache size", sp->st_cache_size);
/*
* Construct a {name {flag1 flag2 ... flagN}} list for the
* seq flags.
*/
myobjv[0] = NewStringObj("Flags", strlen("Flags"));
myobjv[1] =
_GetFlagsList(interp, sp->st_flags, __db_get_seq_flags_fn());
flaglist = Tcl_NewListObj(2, myobjv);
if (flaglist == NULL) {
result = TCL_ERROR;
goto error;
}
if ((result =
Tcl_ListObjAppendElement(interp, res, flaglist)) != TCL_OK)
goto error;
Tcl_SetObjResult(interp, res);
error: __os_ufree(seq->seq_dbp->env, sp);
return (result);
}
/*
* tcl_db_close --
*/
static int
tcl_SeqClose(interp, objc, objv, seq, ip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_SEQUENCE *seq; /* Database pointer */
DBTCL_INFO *ip; /* Info pointer */
{
int result, ret;
result = TCL_OK;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
return (TCL_ERROR);
}
_DeleteInfo(ip);
_debug_check();
ret = seq->close(seq, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "sequence close");
return (result);
}
/*
* tcl_SeqGet --
*/
static int
tcl_SeqGet(interp, objc, objv, seq)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_SEQUENCE *seq; /* Sequence pointer */
{
static const char *seqgetopts[] = {
"-nosync",
"-txn",
NULL
};
enum seqgetopts {
SEQGET_NOSYNC,
SEQGET_TXN
};
DB_TXN *txn;
Tcl_Obj *res;
db_seq_t value;
u_int32_t aflag, delta;
int i, end, optindex, result, ret;
char *arg, msg[MSG_SIZE];
result = TCL_OK;
txn = NULL;
aflag = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args? delta");
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
end = objc;
while (i < end) {
if (Tcl_GetIndexFromObj(interp, objv[i], seqgetopts, "option",
TCL_EXACT, &optindex) != TCL_OK) {
arg = Tcl_GetStringFromObj(objv[i], NULL);
if (arg[0] == '-') {
result = IS_HELP(objv[i]);
goto out;
} else
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum seqgetopts)optindex) {
case SEQGET_NOSYNC:
aflag |= DB_TXN_NOSYNC;
break;
case SEQGET_TXN:
if (i >= end) {
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
result = TCL_ERROR;
break;
}
arg = Tcl_GetStringFromObj(objv[i++], NULL);
txn = NAME_TO_TXN(arg);
if (txn == NULL) {
snprintf(msg, MSG_SIZE,
"Get: Invalid txn: %s\n", arg);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
result = TCL_ERROR;
}
break;
} /* switch */
if (result != TCL_OK)
break;
}
if (result != TCL_OK)
goto out;
if (i != objc - 1) {
Tcl_SetResult(interp,
"Wrong number of key/data given\n", TCL_STATIC);
result = TCL_ERROR;
goto out;
}
if ((result = _GetUInt32(interp, objv[objc - 1], &delta)) != TCL_OK)
goto out;
ret = seq->get(seq, txn, (int32_t)delta, &value, aflag);
result = _ReturnSetup(interp, ret, DB_RETOK_DBGET(ret), "sequence get");
if (ret == 0) {
res = Tcl_NewWideIntObj((Tcl_WideInt)value);
Tcl_SetObjResult(interp, res);
}
out:
return (result);
}
/*
*/
static int
tcl_SeqRemove(interp, objc, objv, seq, ip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_SEQUENCE *seq; /* Sequence pointer */
DBTCL_INFO *ip; /* Info pointer */
{
static const char *seqgetopts[] = {
"-nosync",
"-txn",
NULL
};
enum seqgetopts {
SEQGET_NOSYNC,
SEQGET_TXN
};
DB_TXN *txn;
u_int32_t aflag;
int i, end, optindex, result, ret;
char *arg, msg[MSG_SIZE];
result = TCL_OK;
txn = NULL;
aflag = 0;
_DeleteInfo(ip);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-args?");
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the options
* defined above.
*/
i = 2;
end = objc;
while (i < end) {
if (Tcl_GetIndexFromObj(interp, objv[i], seqgetopts, "option",
TCL_EXACT, &optindex) != TCL_OK) {
arg = Tcl_GetStringFromObj(objv[i], NULL);
if (arg[0] == '-') {
result = IS_HELP(objv[i]);
goto out;
} else
Tcl_ResetResult(interp);
break;
}
i++;
switch ((enum seqgetopts)optindex) {
case SEQGET_NOSYNC:
aflag |= DB_TXN_NOSYNC;
break;
case SEQGET_TXN:
if (i >= end) {
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
result = TCL_ERROR;
break;
}
arg = Tcl_GetStringFromObj(objv[i++], NULL);
txn = NAME_TO_TXN(arg);
if (txn == NULL) {
snprintf(msg, MSG_SIZE,
"Remove: Invalid txn: %s\n", arg);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
result = TCL_ERROR;
}
break;
} /* switch */
if (result != TCL_OK)
break;
}
if (result != TCL_OK)
goto out;
ret = seq->remove(seq, txn, aflag);
result = _ReturnSetup(interp,
ret, DB_RETOK_DBGET(ret), "sequence remove");
out:
return (result);
}
/*
* tcl_SeqGetFlags --
*/
static int
tcl_SeqGetFlags(interp, objc, objv, seq)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_SEQUENCE *seq; /* Sequence pointer */
{
int i, ret, result;
u_int32_t flags;
char buf[512];
Tcl_Obj *res;
static const struct {
u_int32_t flag;
char *arg;
} seq_flags[] = {
{ DB_SEQ_INC, "-inc" },
{ DB_SEQ_DEC, "-dec" },
{ DB_SEQ_WRAP, "-wrap" },
{ 0, NULL }
};
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
ret = seq->get_flags(seq, &flags);
if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"db get_flags")) == TCL_OK) {
buf[0] = '\0';
for (i = 0; seq_flags[i].flag != 0; i++)
if (LF_ISSET(seq_flags[i].flag)) {
if (strlen(buf) > 0)
(void)strncat(buf, " ", sizeof(buf));
(void)strncat(
buf, seq_flags[i].arg, sizeof(buf));
}
res = NewStringObj(buf, strlen(buf));
Tcl_SetObjResult(interp, res);
}
return (result);
}
#endif /* HAVE_64BIT_TYPES */

778
tcl/tcl_txn.c Normal file
View File

@@ -0,0 +1,778 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_txn.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
static int tcl_TxnCommit __P((Tcl_Interp *,
int, Tcl_Obj * CONST *, DB_TXN *, DBTCL_INFO *));
static int txn_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST *));
/*
* _TxnInfoDelete --
* Removes nested txn info structures that are children
* of this txn.
* RECURSIVE: Transactions can be arbitrarily nested, so we
* must recurse down until we get them all.
*
* PUBLIC: void _TxnInfoDelete __P((Tcl_Interp *, DBTCL_INFO *));
*/
void
_TxnInfoDelete(interp, txnip)
Tcl_Interp *interp; /* Interpreter */
DBTCL_INFO *txnip; /* Info for txn */
{
DBTCL_INFO *nextp, *p;
for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
/*
* Check if this info structure "belongs" to this
* txn. Remove its commands and info structure.
*/
nextp = LIST_NEXT(p, entries);
if (p->i_parent == txnip && p->i_type == I_TXN) {
_TxnInfoDelete(interp, p);
(void)Tcl_DeleteCommand(interp, p->i_name);
_DeleteInfo(p);
}
}
}
/*
* tcl_TxnCheckpoint --
*
* PUBLIC: int tcl_TxnCheckpoint __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_TxnCheckpoint(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
static const char *txnckpopts[] = {
"-force",
"-kbyte",
"-min",
NULL
};
enum txnckpopts {
TXNCKP_FORCE,
TXNCKP_KB,
TXNCKP_MIN
};
u_int32_t flags;
int i, kb, min, optindex, result, ret;
result = TCL_OK;
flags = 0;
kb = min = 0;
/*
* Get the flag index from the object based on the options
* defined above.
*/
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
txnckpopts, "option", TCL_EXACT, &optindex) != TCL_OK) {
return (IS_HELP(objv[i]));
}
i++;
switch ((enum txnckpopts)optindex) {
case TXNCKP_FORCE:
flags = DB_FORCE;
break;
case TXNCKP_KB:
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-kbyte kb?");
result = TCL_ERROR;
break;
}
result = Tcl_GetIntFromObj(interp, objv[i++], &kb);
break;
case TXNCKP_MIN:
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv, "?-min min?");
result = TCL_ERROR;
break;
}
result = Tcl_GetIntFromObj(interp, objv[i++], &min);
break;
}
}
_debug_check();
ret = dbenv->txn_checkpoint(dbenv, (u_int32_t)kb, (u_int32_t)min,
flags);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn checkpoint");
return (result);
}
/*
* tcl_Txn --
*
* PUBLIC: int tcl_Txn __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *, DBTCL_INFO *));
*/
int
tcl_Txn(interp, objc, objv, dbenv, envip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
DBTCL_INFO *envip; /* Info pointer */
{
static const char *txnopts[] = {
#ifdef CONFIG_TEST
"-lock_timeout",
"-read_committed",
"-read_uncommitted",
"-txn_timeout",
"-txn_wait",
#endif
"-nosync",
"-nowait",
"-parent",
"-snapshot",
"-sync",
"-wrnosync",
NULL
};
enum txnopts {
#ifdef CONFIG_TEST
TXNLOCK_TIMEOUT,
TXNREAD_COMMITTED,
TXNREAD_UNCOMMITTED,
TXNTIMEOUT,
TXNWAIT,
#endif
TXNNOSYNC,
TXNNOWAIT,
TXNPARENT,
TXNSNAPSHOT,
TXNSYNC,
TXNWRNOSYNC
};
DBTCL_INFO *ip;
DB_TXN *parent;
DB_TXN *txn;
Tcl_Obj *res;
u_int32_t flag;
int i, optindex, result, ret;
char *arg, msg[MSG_SIZE], newname[MSG_SIZE];
#ifdef CONFIG_TEST
db_timeout_t lk_time, tx_time;
u_int32_t lk_timeflag, tx_timeflag;
#endif
result = TCL_OK;
memset(newname, 0, MSG_SIZE);
parent = NULL;
flag = 0;
#ifdef CONFIG_TEST
COMPQUIET(tx_time, 0);
COMPQUIET(lk_time, 0);
lk_timeflag = tx_timeflag = 0;
#endif
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i],
txnopts, "option", TCL_EXACT, &optindex) != TCL_OK) {
return (IS_HELP(objv[i]));
}
i++;
switch ((enum txnopts)optindex) {
#ifdef CONFIG_TEST
case TXNLOCK_TIMEOUT:
lk_timeflag = DB_SET_LOCK_TIMEOUT;
goto get_timeout;
case TXNTIMEOUT:
tx_timeflag = DB_SET_TXN_TIMEOUT;
get_timeout: if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-txn_timestamp time?");
return (TCL_ERROR);
}
result = Tcl_GetLongFromObj(interp, objv[i++], (long *)
((enum txnopts)optindex == TXNLOCK_TIMEOUT ?
&lk_time : &tx_time));
if (result != TCL_OK)
return (TCL_ERROR);
break;
case TXNREAD_COMMITTED:
flag |= DB_READ_COMMITTED;
break;
case TXNREAD_UNCOMMITTED:
flag |= DB_READ_UNCOMMITTED;
break;
case TXNWAIT:
flag |= DB_TXN_WAIT;
break;
#endif
case TXNNOSYNC:
flag |= DB_TXN_NOSYNC;
break;
case TXNNOWAIT:
flag |= DB_TXN_NOWAIT;
break;
case TXNPARENT:
if (i == objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-parent txn?");
result = TCL_ERROR;
break;
}
arg = Tcl_GetStringFromObj(objv[i++], NULL);
parent = NAME_TO_TXN(arg);
if (parent == NULL) {
snprintf(msg, MSG_SIZE,
"Invalid parent txn: %s\n",
arg);
Tcl_SetResult(interp, msg, TCL_VOLATILE);
return (TCL_ERROR);
}
break;
case TXNSNAPSHOT:
flag |= DB_TXN_SNAPSHOT;
break;
case TXNSYNC:
flag |= DB_TXN_SYNC;
break;
case TXNWRNOSYNC:
flag |= DB_TXN_WRITE_NOSYNC;
break;
}
}
snprintf(newname, sizeof(newname), "%s.txn%d",
envip->i_name, envip->i_envtxnid);
ip = _NewInfo(interp, NULL, newname, I_TXN);
if (ip == NULL) {
Tcl_SetResult(interp, "Could not set up info",
TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->txn_begin(dbenv, parent, &txn, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn");
if (result == TCL_ERROR)
_DeleteInfo(ip);
else {
/*
* Success. Set up return. Set up new info
* and command widget for this txn.
*/
envip->i_envtxnid++;
if (parent)
ip->i_parent = _PtrToInfo(parent);
else
ip->i_parent = envip;
_SetInfoData(ip, txn);
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)txn_Cmd, (ClientData)txn, NULL);
res = NewStringObj(newname, strlen(newname));
Tcl_SetObjResult(interp, res);
#ifdef CONFIG_TEST
if (tx_timeflag != 0) {
ret = txn->set_timeout(txn, tx_time, tx_timeflag);
if (ret != 0) {
result =
_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"set_timeout");
_DeleteInfo(ip);
}
}
if (lk_timeflag != 0) {
ret = txn->set_timeout(txn, lk_time, lk_timeflag);
if (ret != 0) {
result =
_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"set_timeout");
_DeleteInfo(ip);
}
}
#endif
}
return (result);
}
/*
* tcl_CDSGroup --
*
* PUBLIC: int tcl_CDSGroup __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *, DBTCL_INFO *));
*/
int
tcl_CDSGroup(interp, objc, objv, dbenv, envip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
DBTCL_INFO *envip; /* Info pointer */
{
DBTCL_INFO *ip;
DB_TXN *txn;
Tcl_Obj *res;
int result, ret;
char newname[MSG_SIZE];
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "env cdsgroup");
return (TCL_ERROR);
}
result = TCL_OK;
memset(newname, 0, MSG_SIZE);
snprintf(newname, sizeof(newname), "%s.txn%d",
envip->i_name, envip->i_envtxnid);
ip = _NewInfo(interp, NULL, newname, I_TXN);
if (ip == NULL) {
Tcl_SetResult(interp, "Could not set up info",
TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->cdsgroup_begin(dbenv, &txn);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "cdsgroup");
if (result == TCL_ERROR)
_DeleteInfo(ip);
else {
/*
* Success. Set up return. Set up new info
* and command widget for this txn.
*/
envip->i_envtxnid++;
ip->i_parent = envip;
_SetInfoData(ip, txn);
(void)Tcl_CreateObjCommand(interp, newname,
(Tcl_ObjCmdProc *)txn_Cmd, (ClientData)txn, NULL);
res = NewStringObj(newname, strlen(newname));
Tcl_SetObjResult(interp, res);
}
return (result);
}
/*
* tcl_TxnStat --
*
* PUBLIC: int tcl_TxnStat __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_TxnStat(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
DBTCL_INFO *ip;
DB_TXN_ACTIVE *p;
DB_TXN_STAT *sp;
Tcl_Obj *myobjv[2], *res, *thislist, *lsnlist;
u_int32_t i;
int myobjc, result, ret;
result = TCL_OK;
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->txn_stat(dbenv, &sp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn stat");
if (result == TCL_ERROR)
return (result);
/*
* Have our stats, now construct the name value
* list pairs and free up the memory.
*/
res = Tcl_NewObj();
/*
* MAKE_STAT_LIST assumes 'res' and 'error' label.
*/
#ifdef HAVE_STATISTICS
MAKE_STAT_LIST("Region size", sp->st_regsize);
MAKE_STAT_LSN("LSN of last checkpoint", &sp->st_last_ckp);
MAKE_STAT_LIST("Time of last checkpoint", sp->st_time_ckp);
MAKE_STAT_LIST("Last txn ID allocated", sp->st_last_txnid);
MAKE_STAT_LIST("Maximum txns", sp->st_maxtxns);
MAKE_STAT_LIST("Number aborted txns", sp->st_naborts);
MAKE_STAT_LIST("Number txns begun", sp->st_nbegins);
MAKE_STAT_LIST("Number committed txns", sp->st_ncommits);
MAKE_STAT_LIST("Number active txns", sp->st_nactive);
MAKE_STAT_LIST("Number of snapshot txns", sp->st_nsnapshot);
MAKE_STAT_LIST("Number restored txns", sp->st_nrestores);
MAKE_STAT_LIST("Maximum active txns", sp->st_maxnactive);
MAKE_STAT_LIST("Maximum snapshot txns", sp->st_maxnsnapshot);
MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
for (i = 0, p = sp->st_txnarray; i < sp->st_nactive; i++, p++)
LIST_FOREACH(ip, &__db_infohead, entries) {
if (ip->i_type != I_TXN)
continue;
if (ip->i_type == I_TXN &&
(ip->i_txnp->id(ip->i_txnp) == p->txnid)) {
MAKE_STAT_LSN(ip->i_name, &p->lsn);
if (p->parentid != 0)
MAKE_STAT_STRLIST("Parent",
ip->i_parent->i_name);
else
MAKE_STAT_LIST("Parent", 0);
break;
}
}
#endif
Tcl_SetObjResult(interp, res);
error:
__os_ufree(dbenv->env, sp);
return (result);
}
/*
* tcl_TxnTimeout --
*
* PUBLIC: int tcl_TxnTimeout __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
*/
int
tcl_TxnTimeout(interp, objc, objv, dbenv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
{
long timeout;
int result, ret;
/*
* One arg, the timeout.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?timeout?");
return (TCL_ERROR);
}
result = Tcl_GetLongFromObj(interp, objv[2], &timeout);
if (result != TCL_OK)
return (result);
_debug_check();
ret = dbenv->set_timeout(dbenv, (u_int32_t)timeout, DB_SET_TXN_TIMEOUT);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"lock timeout");
return (result);
}
/*
* txn_Cmd --
* Implements the "txn" widget.
*/
static int
txn_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Txn handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *txncmds[] = {
#ifdef CONFIG_TEST
"discard",
"getname",
"id",
"prepare",
"setname",
#endif
"abort",
"commit",
"getname",
"setname",
NULL
};
enum txncmds {
#ifdef CONFIG_TEST
TXNDISCARD,
TXNGETNAME,
TXNID,
TXNPREPARE,
TXNSETNAME,
#endif
TXNABORT,
TXNCOMMIT
};
DBTCL_INFO *txnip;
DB_TXN *txnp;
Tcl_Obj *res;
int cmdindex, result, ret;
#ifdef CONFIG_TEST
u_int8_t *gid, garray[DB_XIDDATASIZE];
int length;
const char *name;
#endif
Tcl_ResetResult(interp);
txnp = (DB_TXN *)clientData;
txnip = _PtrToInfo((void *)txnp);
result = TCL_OK;
if (txnp == NULL) {
Tcl_SetResult(interp, "NULL txn pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (txnip == NULL) {
Tcl_SetResult(interp, "NULL txn info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the dbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], txncmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum txncmds)cmdindex) {
#ifdef CONFIG_TEST
case TXNDISCARD:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = txnp->discard(txnp, 0);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn discard");
_TxnInfoDelete(interp, txnip);
(void)Tcl_DeleteCommand(interp, txnip->i_name);
_DeleteInfo(txnip);
break;
case TXNID:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
res = Tcl_NewIntObj((int)txnp->id(txnp));
break;
case TXNPREPARE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
gid = (u_int8_t *)Tcl_GetByteArrayFromObj(objv[2], &length);
memcpy(garray, gid, (size_t)length);
ret = txnp->prepare(txnp, garray);
/*
* !!!
* DB_TXN->prepare commits all outstanding children. But it
* does NOT destroy the current txn handle. So, we must call
* _TxnInfoDelete to recursively remove all nested txn handles,
* we do not call _DeleteInfo on ourselves.
*/
_TxnInfoDelete(interp, txnip);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn prepare");
break;
case TXNGETNAME:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = txnp->get_name(txnp, &name);
if ((result = _ReturnSetup(
interp, ret, DB_RETOK_STD(ret), "txn getname")) == TCL_OK)
res = NewStringObj(name, strlen(name));
break;
case TXNSETNAME:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return (TCL_ERROR);
}
_debug_check();
ret = txnp->set_name(txnp, Tcl_GetStringFromObj(objv[2], NULL));
result =
_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "setname");
break;
#endif
case TXNABORT:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = txnp->abort(txnp);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn abort");
_TxnInfoDelete(interp, txnip);
(void)Tcl_DeleteCommand(interp, txnip->i_name);
_DeleteInfo(txnip);
break;
case TXNCOMMIT:
result = tcl_TxnCommit(interp, objc, objv, txnp, txnip);
_TxnInfoDelete(interp, txnip);
(void)Tcl_DeleteCommand(interp, txnip->i_name);
_DeleteInfo(txnip);
break;
}
/*
* Only set result if we have a res. Otherwise, lower
* functions have already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}
static int
tcl_TxnCommit(interp, objc, objv, txnp, txnip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_TXN *txnp; /* Transaction pointer */
DBTCL_INFO *txnip; /* Info pointer */
{
static const char *commitopt[] = {
"-nosync",
"-sync",
"-wrnosync",
NULL
};
enum commitopt {
COMNOSYNC,
COMSYNC,
COMWRNOSYNC
};
u_int32_t flag;
int optindex, result, ret;
COMPQUIET(txnip, NULL);
result = TCL_OK;
flag = 0;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return (TCL_ERROR);
}
if (objc == 3) {
if (Tcl_GetIndexFromObj(interp, objv[2], commitopt,
"option", TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(objv[2]));
switch ((enum commitopt)optindex) {
case COMSYNC:
flag = DB_TXN_SYNC;
break;
case COMNOSYNC:
flag = DB_TXN_NOSYNC;
break;
case COMWRNOSYNC:
flag = DB_TXN_WRITE_NOSYNC;
break;
}
}
_debug_check();
ret = txnp->commit(txnp, flag);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn commit");
return (result);
}
#ifdef CONFIG_TEST
/*
* tcl_TxnRecover --
*
* PUBLIC: int tcl_TxnRecover __P((Tcl_Interp *, int,
* PUBLIC: Tcl_Obj * CONST*, DB_ENV *, DBTCL_INFO *));
*/
int
tcl_TxnRecover(interp, objc, objv, dbenv, envip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *dbenv; /* Environment pointer */
DBTCL_INFO *envip; /* Info pointer */
{
#define DO_PREPLIST(count) \
for (i = 0; i < count; i++) { \
snprintf(newname, sizeof(newname), "%s.txn%d", \
envip->i_name, envip->i_envtxnid); \
ip = _NewInfo(interp, NULL, newname, I_TXN); \
if (ip == NULL) { \
Tcl_SetResult(interp, "Could not set up info", \
TCL_STATIC); \
return (TCL_ERROR); \
} \
envip->i_envtxnid++; \
ip->i_parent = envip; \
p = &prep[i]; \
_SetInfoData(ip, p->txn); \
(void)Tcl_CreateObjCommand(interp, newname, \
(Tcl_ObjCmdProc *)txn_Cmd, (ClientData)p->txn, NULL); \
result = _SetListElem(interp, res, newname, strlen(newname), \
p->gid, DB_XIDDATASIZE); \
if (result != TCL_OK) \
goto error; \
}
DBTCL_INFO *ip;
DB_PREPLIST prep[DBTCL_PREP], *p;
Tcl_Obj *res;
long count, i;
int result, ret;
char newname[MSG_SIZE];
result = TCL_OK;
/*
* No args for this. Error if there are some.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = dbenv->txn_recover(dbenv, prep, DBTCL_PREP, &count, DB_FIRST);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn recover");
if (result == TCL_ERROR)
return (result);
res = Tcl_NewObj();
DO_PREPLIST(count);
/*
* If count returned is the maximum size we have, then there
* might be more. Keep going until we get them all.
*/
while (count == DBTCL_PREP) {
ret = dbenv->txn_recover(
dbenv, prep, DBTCL_PREP, &count, DB_NEXT);
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
"txn recover");
if (result == TCL_ERROR)
return (result);
DO_PREPLIST(count);
}
Tcl_SetObjResult(interp, res);
error:
return (result);
}
#endif

109
tcl/tcl_util.c Normal file
View File

@@ -0,0 +1,109 @@
/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999,2008 Oracle. All rights reserved.
*
* $Id: tcl_util.c 63573 2008-05-23 21:43:21Z trent.nelson $
*/
#include "db_config.h"
#include "db_int.h"
#ifdef HAVE_SYSTEM_INCLUDE_FILES
#include <tcl.h>
#endif
#include "dbinc/tcl_db.h"
/*
* bdb_RandCommand --
* Implements rand* functions.
*
* PUBLIC: int bdb_RandCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
*/
int
bdb_RandCommand(interp, objc, objv)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static const char *rcmds[] = {
"rand", "random_int", "srand",
NULL
};
enum rcmds {
RRAND, RRAND_INT, RSRAND
};
Tcl_Obj *res;
int cmdindex, hi, lo, result, ret;
result = TCL_OK;
/*
* Get the command name index from the object based on the cmds
* defined above. This SHOULD NOT fail because we already checked
* in the 'berkdb' command.
*/
if (Tcl_GetIndexFromObj(interp,
objv[1], rcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum rcmds)cmdindex) {
case RRAND:
/*
* Must be 0 args. Error if different.
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
ret = rand();
res = Tcl_NewIntObj(ret);
break;
case RRAND_INT:
/*
* Must be 4 args. Error if different.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "lo hi");
return (TCL_ERROR);
}
if ((result =
Tcl_GetIntFromObj(interp, objv[2], &lo)) != TCL_OK)
return (result);
if ((result =
Tcl_GetIntFromObj(interp, objv[3], &hi)) != TCL_OK)
return (result);
if (lo < 0 || hi < 0) {
Tcl_SetResult(interp,
"Range value less than 0", TCL_STATIC);
return (TCL_ERROR);
}
_debug_check();
ret = lo + rand() % ((hi - lo) + 1);
res = Tcl_NewIntObj(ret);
break;
case RSRAND:
/*
* Must be 1 arg. Error if different.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "seed");
return (TCL_ERROR);
}
if ((result =
Tcl_GetIntFromObj(interp, objv[2], &lo)) == TCL_OK) {
srand((u_int)lo);
res = Tcl_NewIntObj(0);
}
break;
}
/*
* Only set result if we have a res. Otherwise, lower functions have
* already done so.
*/
if (result == TCL_OK && res)
Tcl_SetObjResult(interp, res);
return (result);
}