diff options
| author | Zhang Qiang <qiang.z.zhang@intel.com> | 2012-05-29 12:22:00 +0800 |
|---|---|---|
| committer | Zhang Qiang <qiang.z.zhang@intel.com> | 2012-05-29 12:22:00 +0800 |
| commit | 02f0634ac29e19c68279e5544cac963e7f1203b8 (patch) | |
| tree | b983472f94ef063cedf866d8ecfb55939171779d /tcl | |
| parent | e776056ea09ba0b6d9505ced6913c9190a12d632 (diff) | |
| download | db4-02f0634ac29e19c68279e5544cac963e7f1203b8.tar.gz db4-02f0634ac29e19c68279e5544cac963e7f1203b8.tar.bz2 db4-02f0634ac29e19c68279e5544cac963e7f1203b8.zip | |
Diffstat (limited to 'tcl')
| -rw-r--r-- | tcl/docs/db.html | 267 | ||||
| -rw-r--r-- | tcl/docs/env.html | 344 | ||||
| -rw-r--r-- | tcl/docs/historic.html | 168 | ||||
| -rw-r--r-- | tcl/docs/index.html | 50 | ||||
| -rw-r--r-- | tcl/docs/library.html | 26 | ||||
| -rw-r--r-- | tcl/docs/lock.html | 206 | ||||
| -rw-r--r-- | tcl/docs/log.html | 123 | ||||
| -rw-r--r-- | tcl/docs/mpool.html | 189 | ||||
| -rw-r--r-- | tcl/docs/rep.html | 50 | ||||
| -rw-r--r-- | tcl/docs/sequence.html | 93 | ||||
| -rw-r--r-- | tcl/docs/test.html | 103 | ||||
| -rw-r--r-- | tcl/docs/txn.html | 69 | ||||
| -rw-r--r-- | tcl/tcl_compat.c | 738 | ||||
| -rw-r--r-- | tcl/tcl_db.c | 3465 | ||||
| -rw-r--r-- | tcl/tcl_db_pkg.c | 4398 | ||||
| -rw-r--r-- | tcl/tcl_dbcursor.c | 1056 | ||||
| -rw-r--r-- | tcl/tcl_env.c | 2670 | ||||
| -rw-r--r-- | tcl/tcl_internal.c | 817 | ||||
| -rw-r--r-- | tcl/tcl_lock.c | 775 | ||||
| -rw-r--r-- | tcl/tcl_log.c | 770 | ||||
| -rw-r--r-- | tcl/tcl_mp.c | 939 | ||||
| -rw-r--r-- | tcl/tcl_mutex.c | 315 | ||||
| -rw-r--r-- | tcl/tcl_rep.c | 1426 | ||||
| -rw-r--r-- | tcl/tcl_seq.c | 511 | ||||
| -rw-r--r-- | tcl/tcl_txn.c | 778 | ||||
| -rw-r--r-- | tcl/tcl_util.c | 121 |
26 files changed, 20467 insertions, 0 deletions
diff --git a/tcl/docs/db.html b/tcl/docs/db.html new file mode 100644 index 0000000..02429af --- /dev/null +++ b/tcl/docs/db.html @@ -0,0 +1,267 @@ +<!--Copyright 1999-2009 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>[-compress]</B><dd> +Enables default compression using the +<A HREF="../../docs/api_c/db_set_bt_compress.html">DB->set_bt_compress</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. 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. If the command is given the <B>-env</B> option, then we +will accordingly verify the database filename within the context of that +environment. 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. 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). We use the <I>Tcl_CreateObjCommand() </I> +to create the top level database function. 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. 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. 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>. 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. 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> diff --git a/tcl/docs/env.html b/tcl/docs/env.html new file mode 100644 index 0000000..eba6fb1 --- /dev/null +++ b/tcl/docs/env.html @@ -0,0 +1,344 @@ +<!--Copyright 1999-2009 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. 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 by invoking: +<p><b>> berkdb env</b> +<br><b> [-cdb] [-cdb_alldb] [-lock] [-log] [-txn [nosync]]</b> +<br><b> [-create] [-home<i> directory</i>] [-mode <i>mode</i>]</b> +<br><b> [-data_dir <i>directory</i>] [-log_dir <i>directory</i>] +[-tmp_dir <i>directory</i>]</b> +<br><b> [-nommap] [-private] [-recover] [-recover_fatal] +[-system_mem] [-errfile <i>filename</i>]</b> +<br><b> [-use_environ] [-use_environ_root] [-verbose +{<i>which </i>on|off}]</b> +<br><b> [-region_init]</b> +<br><b> [-cachesize {<i>gbytes bytes ncaches</i>}]</b> +<br><b> [-mmapsize<i> size</i>]</b> +<br><b> [-log_max <i>max</i>]</b> +<br><b> [-log_buffer <i>size</i>]</b> +<br><b> [-lock_conflict {<i>nmodes </i>{<i>matrix</i>}}]</b> +<br><b> [-lock_detect default|oldest|random|youngest]</b> +<br><b> [-lock_max <i>max</i>]</b> +<br><b> [-lock_max_locks <i>max</i>]</b> +<br><b> [-lock_max_lockers <i>max</i>]</b> +<br><b> [-lock_max_objects <i>max</i>]</b> +<br><b> [-lock_timeout <i>timeout</i>]</b> +<br><b> [-overwrite]</b> +<br><b> [-txn_max <i>max</i>]</b> +<br><b> [-txn_timeout <i>timeout</i>]</b> +<br><b> [-client_timeout <i>seconds</i>]</b> +<br><b> [-server_timeout <i>seconds</i>]</b> +<br><b> [-server <i>hostname</i>]</b> +<br><b> [-rep_master] [-rep_client]</b> +<br><b> [-rep_transport <i>{ machineid sendproc }</i>]</b> +<br> +<p>This command opens up an environment. We automatically set +the DB_THREAD and the DB_INIT_MPOOL flags. 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. 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 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 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. 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 +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. 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. 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 0 (e.g. <b>env0, env1, </b>etc). +We use the <i>Tcl_CreateObjCommand()</i> to create the top level environment +command function. It is through this handle that the user can access +all the commands described in the <a href="#Environment Commands">Environment +Commands</a> section. 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. +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>> <env> verbose <i>which</i> +on|off</b> +<p>This command controls the use of debugging output for the environment. +This command directly translates to a call to the <a href="../../docs/api_c/dbenv_set_verbose.html">DBENV->set_verbose</a> +method call. It returns either a 0 (for success), a DB error message +or it throws a Tcl error with a system message. 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. 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>> <env> close</b> +<p>This command closes an environment and deletes the handle. This +command directly translates to a call to the <a href="../../docs/api_c/env_close.html">DBENV->close</a> +method call. 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. 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. This command directly translates to a call to the <a href="../../docs/api_c/env_remove.html">DBENV->remove</a> +method call. It returns either a 0 (for success), a DB error message +or it throws a Tcl error with a system message. 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 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 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> diff --git a/tcl/docs/historic.html b/tcl/docs/historic.html new file mode 100644 index 0000000..97e33e6 --- /dev/null +++ b/tcl/docs/historic.html @@ -0,0 +1,168 @@ +<!--Copyright 1999-2009 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. <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. 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. It will store +the <B><I>key/data</I></B> pair. 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. It will delete +the <B><I>key</I></B> from the database. 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. 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. 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. 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>. The <B><I>action</I></B> must be either <B>find</B> +or <B>enter</B>. If it is <B>find</B>, it will return the resultant +data. 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. 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. 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). 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 below. 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 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>> <ndbm> close</B> +<P>This command closes the database and renders the handle invalid. +This command directly translates to the dbm_close function call. +It returns either a 0 (for success), 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. +<HR WIDTH="100%"> +<BR><B>> <ndbm> clearerr</B> +<P>This command clears errors the database. This command +directly translates to the dbm_clearerr function call. It returns +either a 0 (for success), or it throws a Tcl error with a system +message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> delete <I>key</I></B> +<P>This command deletes the <B><I>key</I></B> from thedatabase. +This command directly translates to the dbm_delete function call. +It returns either a 0 (for success), or it throws a Tcl error with +a system message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> dirfno</B> +<P>This command directly translates to the dbm_dirfno function call. +It returns either resultts, or it throws a Tcl error with a system +message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> error</B> +<P>This command returns the last error. This command directly +translates to the dbm_error function call. It returns an error string.. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> fetch <I>key</I></B> +<P>This command gets the given <B><I>key</I></B> from the database. +This command directly translates to the dbm_fetch function call. +It returns either the data, or it throws a Tcl error with a system +message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> firstkey</B> +<P>This command returns the first key in the database. This +command directly translates to the dbm_firstkey function call. It +returns either the key, or it throws a Tcl error with a system message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> nextkey</B> +<P>This command returns the next key in the database. This +command directly translates to the dbm_nextkey function call. It +returns either the key, or it throws a Tcl error with a system message. +<P> +<HR WIDTH="100%"> +<BR><B>> <ndbm> pagfno</B> +<P>This command directly translates to the dbm_pagfno function call. +It returns either resultts, or it throws a Tcl error with a system +message. +<BR> +<HR WIDTH="100%"> +<BR><B>> <ndbm> rdonly</B> +<P>This command changes the database to readonly. This command +directly translates to the dbm_rdonly function call. It returns either +a 0 (for success), or it throws a Tcl error with a system message. +<P> +<HR WIDTH="100%"> +<BR><B>> <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. This command directly translates to +the dbm_store function call. It will either <B>insert</B> or <B>replace</B> +the data based on the action given in the third argument. It returns +either a 0 (for success), or it throws a Tcl error with a system +message. +<BR> +<HR WIDTH="100%"> +</BODY> +</HTML> diff --git a/tcl/docs/index.html b/tcl/docs/index.html new file mode 100644 index 0000000..ae35bd6 --- /dev/null +++ b/tcl/docs/index.html @@ -0,0 +1,50 @@ +<!--Copyright 1999-2009 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> diff --git a/tcl/docs/library.html b/tcl/docs/library.html new file mode 100644 index 0000000..a56898e --- /dev/null +++ b/tcl/docs/library.html @@ -0,0 +1,26 @@ +<!--Copyright 1999-2009 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%"> diff --git a/tcl/docs/lock.html b/tcl/docs/lock.html new file mode 100644 index 0000000..abd15c2 --- /dev/null +++ b/tcl/docs/lock.html @@ -0,0 +1,206 @@ +<!--Copyright 1999-2009 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. 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. +We present the general locking functions first, and then those that manipulate +locks. +<p><b>> <env> lock_detect [default|oldest|youngest|random]</b> +<p>This command runs the deadlock detector. It directly translates +to the <a href="../../docs/api_c/lock_detect.html">lock_detect</a> DB call. +It returns either a 0 (for success), a DB error message or it throws a +Tcl error with a system message. 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>> <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. 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>> <env> lock_id</b> +<p>This command returns a unique locker ID value. 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>> <env> lock_id_free </b><i>locker</i> +<p>This command frees the locker allockated by the lock_id call. It directly +translates to the <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>> <env> lock_id_set </b><i>current +max</i> +<p>This 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>> <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. 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 0 (e.g. <b>$env.lock0, $env.lock1, </b>etc). +We use the <i>Tcl_CreateObjCommand()</i> to create the top level locking +command function. It is through this handle that the user can release +the lock. 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>> <lock> put</b> +<p>This command releases the lock referenced by the command. It is +a direct translation of the <a href="../../docs/api_c/lock_put.html">lock_put</a> +function. 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. +<br> +<hr WIDTH="100%"> +<br><a NAME="> <env> lock_vec"></a><b>> <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. It is a direct translation +of the <a href="../../docs/api_c/lock_vec.html">lock_vec</a> function. +This command will return a list of the return values from each operation +specified in the argument list. For the 'put' operations the entry +in the return value list is either a 0 (for success) or an error. +For the 'get' operation, the entry is the lock widget handle, <b>$env.lockN</b> +(as described above in <a href="#> <env> lock_get"><env> lock_get</a>) +or an error. 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. 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. +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. +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. 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. 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>. +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>. +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>. Requires a tuple <b>{put_obj +<i>obj}</i></b></li> +</ul> +</ul> + +<hr WIDTH="100%"> +<br><a NAME="> <env> lock_vec"></a><b>> <env> lock_timeout <i>timeout</i></b> +<p>This command sets the lock timeout for all future locks in this environment. +The timeout is in micorseconds. +<br> +<br> +</body> +</html> diff --git a/tcl/docs/log.html b/tcl/docs/log.html new file mode 100644 index 0000000..02cd399 --- /dev/null +++ b/tcl/docs/log.html @@ -0,0 +1,123 @@ +<!--Copyright 1999-2009 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. Log files are opened when the environment is opened +and closed when the environment is closed. 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>> <env> log_archive [-arch_abs] [-arch_data] [-arch_log]</B> +<P>This command returns a list of log files that are no longer in +use. 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>> <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>. It is a direct call to the <A HREF="../../docs/api_c/log_compare.html">log_compare</A> +function. 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>> <env> log_file <I>lsn</I></B> +<P>This command returns the file name associated with the given <B><I>lsn</I></B>. +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>> <env> log_flush [<I>lsn</I>]</B> +<P>This command flushes the log up to the specified <B><I>lsn</I></B> +or flushes all records if none is given It is a direct call to the +<A HREF="../../docs/api_c/log_flush.html">log_flush</A> +function. 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>> <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. It is a direct call to the <A HREF="../../docs/api_c/log_get.html">log_get</A> +function. It is a way of implementing a manner of log iteration similar +to <A HREF="../../docs/api_tcl/db_cursor.html">cursors</A>. +The information we return is similar to database information. We +return a list where the first item is the LSN (which is a list itself) +and the second item is the data. So it looks like, fully expanded, +<B>{{<I>fileid</I> +<I>offset</I>} +<I>data</I>}.</B> +In the case where DB_NOTFOUND is returned, we return an empty list <B>{}</B>. +All other errors return a Tcl error. 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 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>> <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. It is a direct call to the <A HREF="../../docs/api_c/log_put.html">log_put</A> +function. It returns either an LSN or it throws a Tcl error with +a system message. <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>> <env> log_stat</B> +<P>This command returns the statistics associated with the logging +subsystem. It is a direct call to the <A HREF="../../docs/api_c/log_stat.html">log_stat</A> +function. It returns a list of name/value pairs of the DB_LOG_STAT +structure. +</BODY> +</HTML> diff --git a/tcl/docs/mpool.html b/tcl/docs/mpool.html new file mode 100644 index 0000000..25967e3 --- /dev/null +++ b/tcl/docs/mpool.html @@ -0,0 +1,189 @@ +<!--Copyright 1999-2009 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. +We create a handle to the pool and then use it for a variety of operations. +Some of the memory pool commands use the environment instead. Those are +presented first. +<P><B>> <env> mpool_stat</B> +<P>This command returns the statistics associated with the memory +pool subsystem. It is a direct call to the <A HREF="../../docs/api_c/memp_stat.html">memp_stat</A> +function. It returns a list of name/value pairs of the DB_MPOOL_STAT +structure. +<BR> +<HR WIDTH="100%"> +<BR><B>> <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>. It is a direct call to the <A HREF="../../docs/api_c/memp_sync.html">memp_sync </A> +function. 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>> <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. It is a direct call to the <A HREF="../../docs/api_c/memp_trickle.html">memp_trickle</A> +function. The command will return the number of pages actually written. +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>> <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. It invokes the <A HREF="../../docs/api_c/memp_fopen.html">memp_fopen</A> +function. 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 0 (e.g. <B>$env.mp0, $env.mp1, </B>etc). +We use the <I>Tcl_CreateObjCommand()</I> to create the top level memory +pool functions. It is through this handle that the user can manipulate +the pool. 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. 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"><env> close</A> without closing +the memory pool we can properly clean up. 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>> <mp> close</B> +<P>This command closes the memory pool. It is a direct call to the +<A HREF="../../docs/api_c/memp_fclose.html">memp_close</A> +function. 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. +We must also remove the reference to this handle from the environment. +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>> <mp> fsync</B> +<P>This command flushes all of the file's dirty pages to disk. It +is a direct call to the <A HREF="../../docs/api_c/memp_fsync.html">memp_fsync</A> +function. 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>> <mp> get [-create] [-last] [-new] +[<I>pgno</I>]</B> +<P>This command gets the <B><I>pgno </I></B>page from the memory +pool. 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. +After it successfully gets a handle to a page, 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 0 (e.g. <B>$env.mp0.p0, $env.mp1.p0, </B>etc). +We use the <I>Tcl_CreateObjCommand()</I> to create the top level page functions. +It is through this handle that the user can manipulate the page. +Internally, the handle we get back from DB will be stored as the <I>ClientData</I> +portion of the new command set. We need to store this handle in +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 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>> <pg> pgnum</B> +<P>This command returns the page number associated with this memory pool +page. Primarily it will be used after an <A HREF="#> <mp> get"><mp> +get</A> call. +<BR> +<HR WIDTH="100%"><B>> <pg> pgsize</B> +<P>This command returns the page size associated with this memory pool +page. Primarily it will be used after an <A HREF="#> <mp> get"><mp> +get</A> call. +<BR> +<HR WIDTH="100%"><B>> <pg> set [-clean] [-dirty] [-discard]</B> +<P>This command sets the characteristics of the page. It is a direct +call to the <A HREF="../../docs/api_c/memp_fset.html">memp_fset</A> function. +It returns either a 0 (for success), a DB error message or it throws a +Tcl error with a system message. 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>> <pg> put [-clean] [-dirty] [-discard]</B> +<P>This command will put back the page to the memory pool. It is +a direct call to the <A HREF="../../docs/api_c/memp_fput.html">memp_fput</A> +function. 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. +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>> <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. +It returns a 0 for success or it throws a Tcl error with an error message. +<P> +<HR WIDTH="100%"> +<BR><B>> <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. +It returns a 1 if the page is correctly set to the value and a 0 otherwise. diff --git a/tcl/docs/rep.html b/tcl/docs/rep.html new file mode 100644 index 0000000..3c1e49c --- /dev/null +++ b/tcl/docs/rep.html @@ -0,0 +1,50 @@ +<!--Copyright 1999-2009 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>> <env> rep_process_message <i>machid</i> <i>control</i> +<i>rec</i></b> +<p>This command processes a single incoming replication message. It +is a direct translation of the <a +href="../../docs/api_c/rep_process_message.html">rep_process_message</a> +function. +It returns either a 0 (for success), a DB error message or it throws a +Tcl error with a system message. 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>> <env> rep_elect <i>nsites</i> <i>pri</i> <i>wait</i> +<i>sleep</i></b> +<p>This command causes a replication election. It is a direct translation +of the <a href="../../docs/api_c/rep_elect.html">rep_elect</a> function. +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> diff --git a/tcl/docs/sequence.html b/tcl/docs/sequence.html new file mode 100644 index 0000000..4aceab8 --- /dev/null +++ b/tcl/docs/sequence.html @@ -0,0 +1,93 @@ +<!--Copyright 1999-2009 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>> berkdb sequence [-auto_commit] [-txn txnid] [-create] </b><br> +<div style="margin-left: 40px;"> Implements <a + href="file:///home/ubell/db.new/docs/seq/seq_open.html">DBENV->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;">> 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;">> <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;">> <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;">> <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;">> <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;">> <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;">> <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;">> <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->stat</a> function.<br> +</div> +<hr width="100%"> +</body> +</html> diff --git a/tcl/docs/test.html b/tcl/docs/test.html new file mode 100644 index 0000000..225f6a2 --- /dev/null +++ b/tcl/docs/test.html @@ -0,0 +1,103 @@ +<!--Copyright 1999-2009 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. 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. These variables are linked together +so that changes in one venue are reflected in the other. The names +of the variables have been modified a bit to reduce the likelihood +<BR>of namespace trampling. 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. The purpose of the debugging, fundamentally, is +to allow the user to set a breakpoint prior to making a DB call. +This breakpoint is set in the <I>__db_loadme() </I>function. 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. 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> 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. 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>> <env> test copy <I>location</I></B> +<BR><B>> <db> test copy <I>location</I></B> +<BR><B>> <env> test abort <I>location</I></B> +<BR><B>> <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. Also we want to invoke a copy +function to copy the database file(s) at various points as well so +that we can obtain before/after snapshots of the databases. 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>. The command is available +from either the environment or the database for convenience. 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. 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> diff --git a/tcl/docs/txn.html b/tcl/docs/txn.html new file mode 100644 index 0000000..3f234a2 --- /dev/null +++ b/tcl/docs/txn.html @@ -0,0 +1,69 @@ +<!--Copyright 1999-2009 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. +We create a handle to the transaction and then use it for a variety +of operations. Some of the transaction commands use the environment +instead. Those are presented first. 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>> <env> txn_checkpoint [-kbyte <i>kb</i>] [-min <i>min</i>]</b> +<p>This command causes a checkpoint of the transaction region. It +is a direct translation of the <a href="../../docs/api_c/txn_checkpoint.html">txn_checkpoint +</a>function. +It returns either a 0 (for success), a DB error message or it throws a +Tcl error with a system message. 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>> <env> txn_stat</b> +<p>This command returns transaction statistics. It is a direct translation +of the <a href="../../docs/api_c/txn_stat.html">txn_stat</a> function. +It will return a list of name/value pairs that correspond to the DB_TXN_STAT +structure. +<hr WIDTH="100%"> +<br><b>> <env> txn_id_set </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>> <txn> id</b> +<p>This command returns the transaction id. It is a direct call to +the <a href="../../docs/api_c/txn_id.html">txn_id</a> function. 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>> <txn> prepare</b> +<p>This command initiates a two-phase commit. It is a direct call +to the <a href="../../docs/api_c/txn_prepare.html">txn_prepare</a> function. +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>> <env> txn_timeout +<i>timeout</i></b> +<p>This command sets thetransaction timeout for transactions started in +the future in this environment. The timeout is in micorseconds. +<br> +<br> +</body> +</html> diff --git a/tcl/tcl_compat.c b/tcl/tcl_compat.c new file mode 100644 index 0000000..6b3664d --- /dev/null +++ b/tcl/tcl_compat.c @@ -0,0 +1,738 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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 */ diff --git a/tcl/tcl_db.c b/tcl/tcl_db.c new file mode 100644 index 0000000..4b68cd9 --- /dev/null +++ b/tcl/tcl_db.c @@ -0,0 +1,3465 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#include "db_config.h" + +#include "db_int.h" +#ifdef HAVE_SYSTEM_INCLUDE_FILES +#include <tcl.h> +#endif +#include "dbinc/db_page.h" +#include "dbinc/db_am.h" +#include "dbinc/tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +static int tcl_DbAssociate __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbClose __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *, DBTCL_INFO *)); +static int tcl_DbDelete __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *, int)); +#ifdef CONFIG_TEST +static int tcl_DbKeyRange __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +#endif +static int tcl_DbPut __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbTruncate __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +#ifdef CONFIG_TEST +static int tcl_DbCompact __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbCompactStat __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *)); +#endif +static int tcl_DbCursor __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *, DBC **)); +static int tcl_DbJoin __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *, DBC **)); +static int tcl_DbGetFlags __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbGetOpenFlags __P((Tcl_Interp *, + int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbGetjoin __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_DbCount __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); +static int tcl_second_call __P((DB *, const DBT *, const DBT *, DBT *)); + +/* + * _DbInfoDelete -- + * + * PUBLIC: void _DbInfoDelete __P((Tcl_Interp *, DBTCL_INFO *)); + */ +void +_DbInfoDelete(interp, dbip) + Tcl_Interp *interp; + DBTCL_INFO *dbip; +{ + DBTCL_INFO *nextp, *p; + /* + * First we have to close any open cursors. Then we close + * our db. + */ + for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) { + nextp = LIST_NEXT(p, entries); + /* + * Check if this is a cursor info structure and if + * it is, if it belongs to this DB. If so, remove + * its commands and info structure. + */ + if (p->i_parent == dbip && p->i_type == I_DBC) { + (void)Tcl_DeleteCommand(interp, p->i_name); + _DeleteInfo(p); + } + } + (void)Tcl_DeleteCommand(interp, dbip->i_name); + _DeleteInfo(dbip); +} + +/* + * + * PUBLIC: int db_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); + * + * db_Cmd -- + * Implements the "db" widget. + */ +int +db_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 *dbcmds[] = { +#ifdef CONFIG_TEST + "keyrange", + "pget", + "rpcid", + "test", + "compact", + "compact_stat", +#endif + "associate", + "close", + "count", + "cursor", + "del", + "get", + "get_bt_minkey", + "get_cachesize", + "get_dbname", + "get_encrypt_flags", + "get_env", + "get_errpfx", + "get_flags", + "get_h_ffactor", + "get_h_nelem", + "get_join", + "get_lorder", + "get_open_flags", + "get_pagesize", + "get_q_extentsize", + "get_re_delim", + "get_re_len", + "get_re_pad", + "get_re_source", + "get_type", + "is_byteswapped", + "join", + "put", + "stat", + "sync", + "truncate", + NULL + }; + enum dbcmds { +#ifdef CONFIG_TEST + DBKEYRANGE, + DBPGET, + DBRPCID, + DBTEST, + DBCOMPACT, + DBCOMPACT_STAT, +#endif + DBASSOCIATE, + DBCLOSE, + DBCOUNT, + DBCURSOR, + DBDELETE, + DBGET, + DBGETBTMINKEY, + DBGETCACHESIZE, + DBGETDBNAME, + DBGETENCRYPTFLAGS, + DBGETENV, + DBGETERRPFX, + DBGETFLAGS, + DBGETHFFACTOR, + DBGETHNELEM, + DBGETJOIN, + DBGETLORDER, + DBGETOPENFLAGS, + DBGETPAGESIZE, + DBGETQEXTENTSIZE, + DBGETREDELIM, + DBGETRELEN, + DBGETREPAD, + DBGETRESOURCE, + DBGETTYPE, + DBSWAPPED, + DBJOIN, + DBPUT, + DBSTAT, + DBSYNC, + DBTRUNCATE + }; + DB *dbp; + DB_ENV *dbenv; + DBC *dbc; + DBTCL_INFO *dbip, *ip; + DBTYPE type; + Tcl_Obj *res, *myobjv[3]; + int cmdindex, intval, ncache, result, ret; + char newname[MSG_SIZE]; + u_int32_t bytes, gbytes, value; + const char *strval, *filename, *dbname, *envid; + + Tcl_ResetResult(interp); + dbp = (DB *)clientData; + dbip = _PtrToInfo((void *)dbp); + memset(newname, 0, MSG_SIZE); + 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], dbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) + return (IS_HELP(objv[1])); + + res = NULL; + switch ((enum dbcmds)cmdindex) { +#ifdef CONFIG_TEST + case DBKEYRANGE: + result = tcl_DbKeyRange(interp, objc, objv, dbp); + break; + case DBPGET: + result = tcl_DbGet(interp, objc, objv, dbp, 1); + break; + case DBRPCID: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + /* + * !!! Retrieve the client ID from the dbp handle directly. + * This is for testing purposes only. It is dbp-private data. + */ + res = Tcl_NewLongObj((long)dbp->cl_id); + break; + case DBTEST: + result = tcl_EnvTest(interp, objc, objv, dbp->dbenv); + break; + + case DBCOMPACT: + result = tcl_DbCompact(interp, objc, objv, dbp); + break; + + case DBCOMPACT_STAT: + result = tcl_DbCompactStat(interp, objc, objv, dbp); + break; + +#endif + case DBASSOCIATE: + result = tcl_DbAssociate(interp, objc, objv, dbp); + break; + case DBCLOSE: + result = tcl_DbClose(interp, objc, objv, dbp, dbip); + break; + case DBDELETE: + result = tcl_DbDelete(interp, objc, objv, dbp); + break; + case DBGET: + result = tcl_DbGet(interp, objc, objv, dbp, 0); + break; + case DBPUT: + result = tcl_DbPut(interp, objc, objv, dbp); + break; + case DBCOUNT: + result = tcl_DbCount(interp, objc, objv, dbp); + break; + case DBSWAPPED: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = dbp->get_byteswapped(dbp, &intval); + res = Tcl_NewIntObj(intval); + break; + case DBGETTYPE: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = dbp->get_type(dbp, &type); + if (type == DB_BTREE) + res = NewStringObj("btree", strlen("btree")); + else if (type == DB_HASH) + res = NewStringObj("hash", strlen("hash")); + else if (type == DB_RECNO) + res = NewStringObj("recno", strlen("recno")); + else if (type == DB_QUEUE) + res = NewStringObj("queue", strlen("queue")); + else { + Tcl_SetResult(interp, + "db gettype: Returned unknown type\n", TCL_STATIC); + result = TCL_ERROR; + } + break; + case DBSTAT: + result = tcl_DbStat(interp, objc, objv, dbp); + break; + case DBSYNC: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = dbp->sync(dbp, 0); + res = Tcl_NewIntObj(ret); + if (ret != 0) { + Tcl_SetObjResult(interp, res); + result = TCL_ERROR; + } + break; + case DBCURSOR: + snprintf(newname, sizeof(newname), + "%s.c%d", dbip->i_name, dbip->i_dbdbcid); + ip = _NewInfo(interp, NULL, newname, I_DBC); + if (ip != NULL) { + result = tcl_DbCursor(interp, objc, objv, dbp, &dbc); + if (result == TCL_OK) { + dbip->i_dbdbcid++; + ip->i_parent = dbip; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)dbc_Cmd, + (ClientData)dbc, NULL); + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, dbc); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, + "Could not set up info", TCL_STATIC); + result = TCL_ERROR; + } + break; + case DBJOIN: + snprintf(newname, sizeof(newname), + "%s.c%d", dbip->i_name, dbip->i_dbdbcid); + ip = _NewInfo(interp, NULL, newname, I_DBC); + if (ip != NULL) { + result = tcl_DbJoin(interp, objc, objv, dbp, &dbc); + if (result == TCL_OK) { + dbip->i_dbdbcid++; + ip->i_parent = dbip; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)dbc_Cmd, + (ClientData)dbc, NULL); + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, dbc); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, + "Could not set up info", TCL_STATIC); + result = TCL_ERROR; + } + break; + case DBGETBTMINKEY: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_bt_minkey(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_bt_minkey")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETCACHESIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_cachesize(dbp, &gbytes, &bytes, &ncache); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_cachesize")) == TCL_OK) { + myobjv[0] = Tcl_NewIntObj((int)gbytes); + myobjv[1] = Tcl_NewIntObj((int)bytes); + myobjv[2] = Tcl_NewIntObj((int)ncache); + res = Tcl_NewListObj(3, myobjv); + } + break; + case DBGETDBNAME: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_dbname(dbp, &filename, &dbname); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_dbname")) == TCL_OK) { + myobjv[0] = NewStringObj(filename, strlen(filename)); + myobjv[1] = NewStringObj(dbname, strlen(dbname)); + res = Tcl_NewListObj(2, myobjv); + } + break; + case DBGETENCRYPTFLAGS: + result = tcl_EnvGetEncryptFlags(interp, objc, objv, dbp->dbenv); + break; + case DBGETENV: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + dbenv = dbp->get_env(dbp); + if (dbenv != NULL && (ip = _PtrToInfo(dbenv)) != NULL) { + envid = ip->i_name; + res = NewStringObj(envid, strlen(envid)); + } else + Tcl_ResetResult(interp); + break; + case DBGETERRPFX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + dbp->get_errpfx(dbp, &strval); + res = NewStringObj(strval, strlen(strval)); + break; + case DBGETFLAGS: + result = tcl_DbGetFlags(interp, objc, objv, dbp); + break; + case DBGETHFFACTOR: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_h_ffactor(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_h_ffactor")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETHNELEM: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_h_nelem(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_h_nelem")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETJOIN: + result = tcl_DbGetjoin(interp, objc, objv, dbp); + break; + case DBGETLORDER: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = dbp->get_lorder(dbp, &intval); + res = Tcl_NewIntObj(intval); + break; + case DBGETOPENFLAGS: + result = tcl_DbGetOpenFlags(interp, objc, objv, dbp); + break; + case DBGETPAGESIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_pagesize(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_pagesize")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETQEXTENTSIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_q_extentsize(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_q_extentsize")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETREDELIM: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_re_delim(dbp, &intval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_re_delim")) == TCL_OK) + res = Tcl_NewIntObj(intval); + break; + case DBGETRELEN: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_re_len(dbp, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_re_len")) == TCL_OK) + res = Tcl_NewIntObj((int)value); + break; + case DBGETREPAD: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_re_pad(dbp, &intval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_re_pad")) == TCL_OK) + res = Tcl_NewIntObj((int)intval); + break; + case DBGETRESOURCE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbp->get_re_source(dbp, &strval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db get_re_source")) == TCL_OK) + res = NewStringObj(strval, strlen(strval)); + break; + case DBTRUNCATE: + result = tcl_DbTruncate(interp, objc, objv, dbp); + 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_DbStat(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbstatopts[] = { +#ifdef CONFIG_TEST + "-read_committed", + "-read_uncommitted", +#endif + "-faststat", + "-txn", + NULL + }; + enum dbstatopts { +#ifdef CONFIG_TEST + DBCUR_READ_COMMITTED, + DBCUR_READ_UNCOMMITTED, +#endif + DBCUR_FASTSTAT, + DBCUR_TXN + }; + DBTYPE type; + DB_BTREE_STAT *bsp; + DB_HASH_STAT *hsp; + DB_QUEUE_STAT *qsp; + DB_TXN *txn; + Tcl_Obj *res, *flaglist, *myobjv[2]; + u_int32_t flag; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + void *sp; + + result = TCL_OK; + flag = 0; + txn = NULL; + sp = NULL; + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbstatopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto error; + } + i++; + switch ((enum dbstatopts)optindex) { +#ifdef CONFIG_TEST + case DBCUR_READ_COMMITTED: + flag |= DB_READ_COMMITTED; + break; + case DBCUR_READ_UNCOMMITTED: + flag |= DB_READ_UNCOMMITTED; + break; +#endif + case DBCUR_FASTSTAT: + flag |= DB_FAST_STAT; + break; + case DBCUR_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, + "Stat: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + if (result != TCL_OK) + break; + } + if (result != TCL_OK) + goto error; + + _debug_check(); + ret = dbp->stat(dbp, txn, &sp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db stat"); + if (result == TCL_ERROR) + return (result); + + (void)dbp->get_type(dbp, &type); + /* + * 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. + */ + if (type == DB_HASH) { + hsp = (DB_HASH_STAT *)sp; + MAKE_STAT_LIST("Magic", hsp->hash_magic); + MAKE_STAT_LIST("Version", hsp->hash_version); + MAKE_STAT_LIST("Page size", hsp->hash_pagesize); + MAKE_STAT_LIST("Page count", hsp->hash_pagecnt); + MAKE_STAT_LIST("Number of keys", hsp->hash_nkeys); + MAKE_STAT_LIST("Number of records", hsp->hash_ndata); + MAKE_STAT_LIST("Fill factor", hsp->hash_ffactor); + MAKE_STAT_LIST("Buckets", hsp->hash_buckets); + if (flag != DB_FAST_STAT) { + MAKE_STAT_LIST("Free pages", hsp->hash_free); + MAKE_WSTAT_LIST("Bytes free", hsp->hash_bfree); + MAKE_STAT_LIST("Number of big pages", + hsp->hash_bigpages); + MAKE_STAT_LIST("Big pages bytes free", + hsp->hash_big_bfree); + MAKE_STAT_LIST("Overflow pages", hsp->hash_overflows); + MAKE_STAT_LIST("Overflow bytes free", + hsp->hash_ovfl_free); + MAKE_STAT_LIST("Duplicate pages", hsp->hash_dup); + MAKE_STAT_LIST("Duplicate pages bytes free", + hsp->hash_dup_free); + } + } else if (type == DB_QUEUE) { + qsp = (DB_QUEUE_STAT *)sp; + MAKE_STAT_LIST("Magic", qsp->qs_magic); + MAKE_STAT_LIST("Version", qsp->qs_version); + MAKE_STAT_LIST("Page size", qsp->qs_pagesize); + MAKE_STAT_LIST("Extent size", qsp->qs_extentsize); + MAKE_STAT_LIST("Number of keys", qsp->qs_nkeys); + MAKE_STAT_LIST("Number of records", qsp->qs_ndata); + MAKE_STAT_LIST("Record length", qsp->qs_re_len); + MAKE_STAT_LIST("Record pad", qsp->qs_re_pad); + MAKE_STAT_LIST("First record number", qsp->qs_first_recno); + MAKE_STAT_LIST("Last record number", qsp->qs_cur_recno); + if (flag != DB_FAST_STAT) { + MAKE_STAT_LIST("Number of pages", qsp->qs_pages); + MAKE_WSTAT_LIST("Bytes free", qsp->qs_pgfree); + } + } else { /* BTREE and RECNO are same stats */ + bsp = (DB_BTREE_STAT *)sp; + MAKE_STAT_LIST("Magic", bsp->bt_magic); + MAKE_STAT_LIST("Version", bsp->bt_version); + MAKE_STAT_LIST("Number of keys", bsp->bt_nkeys); + MAKE_STAT_LIST("Number of records", bsp->bt_ndata); + MAKE_STAT_LIST("Minimum keys per page", bsp->bt_minkey); + MAKE_STAT_LIST("Fixed record length", bsp->bt_re_len); + MAKE_STAT_LIST("Record pad", bsp->bt_re_pad); + MAKE_STAT_LIST("Page size", bsp->bt_pagesize); + MAKE_STAT_LIST("Page count", bsp->bt_pagecnt); + if (flag != DB_FAST_STAT) { + MAKE_STAT_LIST("Levels", bsp->bt_levels); + MAKE_STAT_LIST("Internal pages", bsp->bt_int_pg); + MAKE_STAT_LIST("Leaf pages", bsp->bt_leaf_pg); + MAKE_STAT_LIST("Duplicate pages", bsp->bt_dup_pg); + MAKE_STAT_LIST("Overflow pages", bsp->bt_over_pg); + MAKE_STAT_LIST("Empty pages", bsp->bt_empty_pg); + MAKE_STAT_LIST("Pages on freelist", bsp->bt_free); + MAKE_STAT_LIST("Internal pages bytes free", + bsp->bt_int_pgfree); + MAKE_STAT_LIST("Leaf pages bytes free", + bsp->bt_leaf_pgfree); + MAKE_STAT_LIST("Duplicate pages bytes free", + bsp->bt_dup_pgfree); + MAKE_STAT_LIST("Bytes free in overflow pages", + bsp->bt_over_pgfree); + } + } + + /* + * Construct a {name {flag1 flag2 ... flagN}} list for the + * dbp flags. These aren't access-method dependent, but they + * include all the interesting flags, and the integer value + * isn't useful from Tcl--return the strings instead. + */ + myobjv[0] = NewStringObj("Flags", strlen("Flags")); + myobjv[1] = _GetFlagsList(interp, dbp->flags, __db_get_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: + if (sp != NULL) + __os_ufree(dbp->env, sp); + return (result); +} + +/* + * tcl_db_close -- + */ +static int +tcl_DbClose(interp, objc, objv, dbp, dbip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ + DBTCL_INFO *dbip; /* Info pointer */ +{ + static const char *dbclose[] = { + "-nosync", "--", NULL + }; + enum dbclose { + TCL_DBCLOSE_NOSYNC, + TCL_DBCLOSE_ENDARG + }; + u_int32_t flag; + int endarg, i, optindex, result, ret; + char *arg; + + result = TCL_OK; + endarg = 0; + flag = 0; + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nosync?"); + return (TCL_ERROR); + } + + for (i = 2; i < objc; ++i) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbclose, + "option", TCL_EXACT, &optindex) != TCL_OK) { + arg = Tcl_GetStringFromObj(objv[i], NULL); + if (arg[0] == '-') + return (IS_HELP(objv[i])); + else + Tcl_ResetResult(interp); + break; + } + switch ((enum dbclose)optindex) { + case TCL_DBCLOSE_NOSYNC: + flag = DB_NOSYNC; + break; + case TCL_DBCLOSE_ENDARG: + endarg = 1; + break; + } + /* + * If, at any time, parsing the args we get an error, + * bail out and return. + */ + if (result != TCL_OK) + return (result); + if (endarg) + break; + } + if (dbip->i_cdata != NULL) + __os_free(dbp->env, dbip->i_cdata); + _DbInfoDelete(interp, dbip); + _debug_check(); + + /* Paranoia. */ + dbp->api_internal = NULL; + + ret = (dbp)->close(dbp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db close"); + return (result); +} + +/* + * tcl_db_put -- + */ +static int +tcl_DbPut(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbputopts[] = { +#ifdef CONFIG_TEST + "-nodupdata", +#endif + "-append", + "-multiple", + "-multiple_key", + "-nooverwrite", + "-overwritedup", + "-partial", + "-txn", + NULL + }; + enum dbputopts { +#ifdef CONFIG_TEST + DBGET_NODUPDATA, +#endif + DBPUT_APPEND, + DBPUT_MULTIPLE, + DBPUT_MULTIPLE_KEY, + DBPUT_NOOVER, + DBPUT_OVER, + DBPUT_PART, + DBPUT_TXN + }; + static const char *dbputapp[] = { + "-append", + "-multiple_key", + NULL + }; + enum dbputapp { DBPUT_APPEND0, DBPUT_MULTIPLE_KEY0 }; + DBT key, data; + DBTYPE type; + DB_TXN *txn; + Tcl_Obj **delemv, **elemv, *res; + void *dtmp, *ktmp, *ptr; + db_recno_t recno; + u_int32_t flag, multiflag; + int delemc, elemc, end, freekey, freedata; + int dlen, klen, i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + txn = NULL; + result = TCL_OK; + flag = multiflag = 0; + if (objc <= 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-args? key data"); + return (TCL_ERROR); + } + + dtmp = ktmp = NULL; + freekey = freedata = 0; + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + COMPQUIET(recno, 0); + + /* + * If it is a QUEUE or RECNO database, the key is a record number + * and must be setup up to contain a db_recno_t. Otherwise the + * key is a "string". + */ + (void)dbp->get_type(dbp, &type); + + /* + * We need to determine where the end of required args are. If we are + * using a QUEUE/RECNO db and -append, or -multiple_key is specified, + * then there is just one req arg (data). Otherwise there are two + * (key data). + * + * We preparse the list to determine this since we need to know + * to properly check # of args for other options below. + */ + end = objc - 2; + i = 2; + while (i < objc - 1) { + if (Tcl_GetIndexFromObj(interp, objv[i++], dbputapp, + "option", TCL_EXACT, &optindex) != TCL_OK) + continue; + switch ((enum dbputapp)optindex) { + case DBPUT_APPEND0: + case DBPUT_MULTIPLE_KEY0: + end = objc - 1; + break; + } + } + Tcl_ResetResult(interp); + + /* + * Get the command name index from the object based on the options + * defined above. + */ + i = 2; + while (i < end) { + if (Tcl_GetIndexFromObj(interp, objv[i], + dbputopts, "option", TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(objv[i])); + i++; + switch ((enum dbputopts)optindex) { +#ifdef CONFIG_TEST + case DBGET_NODUPDATA: + FLAG_CHECK(flag); + flag = DB_NODUPDATA; + break; +#endif + case DBPUT_TXN: + if (i > (end - 1)) { + 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, + "Put: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case DBPUT_APPEND: + FLAG_CHECK(flag); + flag = DB_APPEND; + break; + case DBPUT_MULTIPLE: + FLAG_CHECK(multiflag); + multiflag = DB_MULTIPLE; + break; + case DBPUT_MULTIPLE_KEY: + FLAG_CHECK(multiflag); + multiflag = DB_MULTIPLE_KEY; + break; + case DBPUT_NOOVER: + FLAG_CHECK(flag); + flag = DB_NOOVERWRITE; + break; + case DBPUT_OVER: + FLAG_CHECK(flag); + flag = DB_OVERWRITE_DUP; + break; + case DBPUT_PART: + if (i > (end - 1)) { + 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_ERROR) + return (result); + + if (multiflag == DB_MULTIPLE) { + /* + * To work out how big a buffer is needed, we first need to + * find out the total length of the data and the number of data + * items (elemc). + */ + ktmp = Tcl_GetByteArrayFromObj(objv[objc - 2], &klen); + result = Tcl_ListObjGetElements(interp, objv[objc - 2], + &elemc, &elemv); + if (result != TCL_OK) + return (result); + + dtmp = Tcl_GetByteArrayFromObj(objv[objc - 1], &dlen); + result = Tcl_ListObjGetElements(interp, objv[objc - 1], + &delemc, &delemv); + if (result != TCL_OK) + return (result); + + if (elemc < delemc) + delemc = elemc; + else + elemc = delemc; + + memset(&key, 0, sizeof(key)); + key.ulen = DB_ALIGN((u_int32_t)klen + + (u_int32_t)elemc * sizeof(u_int32_t) * 2, 1024UL); + key.flags = DB_DBT_USERMEM | DB_DBT_BULK; + if ((ret = __os_malloc(dbp->env, key.ulen, &key.data)) != 0) + return (ret); + freekey = 1; + + memset(&data, 0, sizeof(data)); + data.ulen = DB_ALIGN((u_int32_t)dlen + + (u_int32_t)delemc * sizeof(u_int32_t) * 2, 1024UL); + data.flags = DB_DBT_USERMEM | DB_DBT_BULK; + if ((ret = __os_malloc(dbp->env, data.ulen, &data.data)) != 0) + return (ret); + freedata = 1; + + if (type == DB_QUEUE || type == DB_RECNO) { + DB_MULTIPLE_RECNO_WRITE_INIT(ptr, &key); + for (i = 0; i < elemc; i++) { + result = _GetUInt32(interp, elemv[i], &recno); + DB_MULTIPLE_RECNO_WRITE_NEXT(ptr, &key, recno, + dtmp, 0); + DB_ASSERT(dbp->env, ptr != NULL); + } + } else { + DB_MULTIPLE_WRITE_INIT(ptr, &key); + for (i = 0; i < elemc; i++) { + ktmp = Tcl_GetByteArrayFromObj(elemv[i], &klen); + DB_MULTIPLE_WRITE_NEXT(ptr, + &key, ktmp, (u_int32_t)klen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } + DB_MULTIPLE_WRITE_INIT(ptr, &data); + for (i = 0; i < elemc; i++) { + dtmp = Tcl_GetByteArrayFromObj(delemv[i], &dlen); + DB_MULTIPLE_WRITE_NEXT(ptr, + &data, dtmp, (u_int32_t)dlen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } else if (multiflag == DB_MULTIPLE_KEY) { + /* + * To work out how big a buffer is needed, we first need to + * find out the total length of the data (len) and the number + * of data items (elemc). + */ + ktmp = Tcl_GetByteArrayFromObj(objv[objc - 1], &klen); + result = Tcl_ListObjGetElements(interp, objv[objc - 1], + &elemc, &elemv); + if (result != TCL_OK) + return (result); + + memset(&key, 0, sizeof(key)); + key.ulen = DB_ALIGN((u_int32_t)klen + + (u_int32_t)elemc * sizeof(u_int32_t) * 2, 1024UL); + key.flags = DB_DBT_USERMEM | DB_DBT_BULK; + if ((ret = __os_malloc(dbp->env, key.ulen, &key.data)) != 0) + return (ret); + freekey = 1; + + if (type == DB_QUEUE || type == DB_RECNO) { + DB_MULTIPLE_RECNO_WRITE_INIT(ptr, &key); + for (i = 0; i + 1 < elemc; i += 2) { + result = _GetUInt32(interp, elemv[i], &recno); + dtmp = Tcl_GetByteArrayFromObj(elemv[i + 1], + &dlen); + DB_MULTIPLE_RECNO_WRITE_NEXT(ptr, &key, + recno, dtmp, (u_int32_t)dlen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } else { + DB_MULTIPLE_WRITE_INIT(ptr, &key); + for (i = 0; i + 1 < elemc; i += 2) { + ktmp = Tcl_GetByteArrayFromObj(elemv[i], &klen); + dtmp = Tcl_GetByteArrayFromObj(elemv[i + 1], + &dlen); + DB_MULTIPLE_KEY_WRITE_NEXT(ptr, + &key, ktmp, (u_int32_t)klen, + dtmp, (u_int32_t)dlen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } + } else if (type == DB_QUEUE || type == DB_RECNO) { + /* + * If we are a recno db and we are NOT using append, then the + * 2nd last arg is the key. + */ + key.data = &recno; + key.ulen = key.size = sizeof(db_recno_t); + key.flags = DB_DBT_USERMEM; + if (flag == DB_APPEND) + recno = 0; + else { + result = _GetUInt32(interp, objv[objc-2], &recno); + if (result != TCL_OK) + return (result); + } + } else { + ret = _CopyObjBytes(interp, objv[objc-2], &ktmp, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBPUT(ret), "db put"); + return (result); + } + key.data = ktmp; + } + + if (multiflag == 0) { + ret = _CopyObjBytes(interp, + objv[objc-1], &dtmp, &data.size, &freedata); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBPUT(ret), "db put"); + goto out; + } + data.data = dtmp; + } + _debug_check(); + ret = dbp->put(dbp, txn, &key, &data, flag | multiflag); + result = _ReturnSetup(interp, ret, DB_RETOK_DBPUT(ret), "db put"); + + /* We may have a returned record number. */ + if (ret == 0 && + (type == DB_QUEUE || type == DB_RECNO) && flag == DB_APPEND) { + res = Tcl_NewWideIntObj((Tcl_WideInt)recno); + Tcl_SetObjResult(interp, res); + } + +out: if (freedata && data.data != NULL) + __os_free(dbp->env, data.data); + if (freekey && key.data != NULL) + __os_free(dbp->env, key.data); + return (result); +} + +/* + * tcl_db_get -- + */ +static int +tcl_DbGet(interp, objc, objv, dbp, ispget) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ + int ispget; /* 1 for pget, 0 for get */ +{ + static const char *dbgetopts[] = { +#ifdef CONFIG_TEST + "-data_buf_size", + "-multi", + "-nolease", + "-read_committed", + "-read_uncommitted", +#endif + "-consume", + "-consume_wait", + "-get_both", + "-glob", + "-partial", + "-recno", + "-rmw", + "-txn", + "--", + NULL + }; + enum dbgetopts { +#ifdef CONFIG_TEST + DBGET_DATA_BUF_SIZE, + DBGET_MULTI, + DBGET_NOLEASE, + DBGET_READ_COMMITTED, + DBGET_READ_UNCOMMITTED, +#endif + DBGET_CONSUME, + DBGET_CONSUME_WAIT, + DBGET_BOTH, + DBGET_GLOB, + DBGET_PART, + DBGET_RECNO, + DBGET_RMW, + DBGET_TXN, + DBGET_ENDARG + }; + DBC *dbc; + DBT key, pkey, data, save; + DBTYPE ptype, type; + DB_TXN *txn; + Tcl_Obj **elemv, *retlist; + db_recno_t precno, recno; + u_int32_t flag, cflag, isdup, mflag, rmw; + int elemc, end, endarg, freekey, freedata, i; + int optindex, result, ret, useglob, useprecno, userecno; + char *arg, *pattern, *prefix, msg[MSG_SIZE]; + void *dtmp, *ktmp; +#ifdef CONFIG_TEST + int bufsize, data_buf_size; +#endif + + result = TCL_OK; + freekey = freedata = 0; + cflag = endarg = flag = mflag = rmw = 0; + useglob = userecno = 0; + txn = NULL; + pattern = prefix = NULL; + dtmp = ktmp = NULL; +#ifdef CONFIG_TEST + COMPQUIET(bufsize, 0); + data_buf_size = 0; +#endif + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-args? key"); + return (TCL_ERROR); + } + + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + memset(&save, 0, sizeof(save)); + + /* For the primary key in a pget call. */ + memset(&pkey, 0, sizeof(pkey)); + + /* + * Get the command name index from the object based on the options + * defined above. + */ + i = 2; + (void)dbp->get_type(dbp, &type); + end = objc; + while (i < end) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbgetopts, "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 dbgetopts)optindex) { +#ifdef CONFIG_TEST + case DBGET_DATA_BUF_SIZE: + result = + Tcl_GetIntFromObj(interp, objv[i], &data_buf_size); + if (result != TCL_OK) + goto out; + i++; + break; + case DBGET_MULTI: + mflag |= DB_MULTIPLE; + result = + Tcl_GetIntFromObj(interp, objv[i], &bufsize); + if (result != TCL_OK) + goto out; + i++; + break; + case DBGET_NOLEASE: + rmw |= DB_IGNORE_LEASE; + break; + case DBGET_READ_COMMITTED: + rmw |= DB_READ_COMMITTED; + break; + case DBGET_READ_UNCOMMITTED: + rmw |= DB_READ_UNCOMMITTED; + break; +#endif + case DBGET_BOTH: + /* + * Change 'end' and make sure we aren't already past + * the new end. + */ + if (i > objc - 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-get_both key data?"); + result = TCL_ERROR; + break; + } + end = objc - 2; + FLAG_CHECK(flag); + flag = DB_GET_BOTH; + break; + case DBGET_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; + case DBGET_GLOB: + useglob = 1; + end = objc - 1; + break; + case DBGET_CONSUME: + FLAG_CHECK(flag); + flag = DB_CONSUME; + break; + case DBGET_CONSUME_WAIT: + FLAG_CHECK(flag); + flag = DB_CONSUME_WAIT; + break; + case DBGET_RECNO: + end = objc - 1; + userecno = 1; + if (type != DB_RECNO && type != DB_QUEUE) { + FLAG_CHECK(flag); + flag = DB_SET_RECNO; + key.flags |= DB_DBT_MALLOC; + } + break; + case DBGET_RMW: + rmw |= DB_RMW; + break; + case DBGET_PART: + end = objc - 1; + if (i == end) { + 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; + } + save.flags = DB_DBT_PARTIAL; + result = _GetUInt32(interp, elemv[0], &save.doff); + if (result != TCL_OK) + break; + result = _GetUInt32(interp, elemv[1], &save.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; + case DBGET_ENDARG: + endarg = 1; + break; + } + if (result != TCL_OK) + break; + if (endarg) + break; + } + if (result != TCL_OK) + goto out; + + if (type == DB_RECNO || type == DB_QUEUE) + userecno = 1; + + /* + * Check args we have left versus the flags we were given. + * We might have 0, 1 or 2 left. If we have 0, it must + * be DB_CONSUME*, if 2, then DB_GET_BOTH, all others should + * be 1. + */ + if (((flag == DB_CONSUME || flag == DB_CONSUME_WAIT) && i != objc) || + (flag == DB_GET_BOTH && i != objc - 2)) { + Tcl_SetResult(interp, + "Wrong number of key/data given based on flags specified\n", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } else if (flag == 0 && i != objc - 1) { + Tcl_SetResult(interp, + "Wrong number of key/data given\n", TCL_STATIC); + result = TCL_ERROR; + goto out; + } + + /* + * Find out whether the primary key should also be a recno. + */ + if (ispget && dbp->s_primary != NULL) { + (void)dbp->s_primary->get_type(dbp->s_primary, &ptype); + useprecno = ptype == DB_RECNO || ptype == DB_QUEUE; + } else + useprecno = 0; + + /* + * Check for illegal combos of options. + */ + if (useglob && (userecno || flag == DB_SET_RECNO || + type == DB_RECNO || type == DB_QUEUE)) { + Tcl_SetResult(interp, + "Cannot use -glob and record numbers.\n", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } +#ifdef CONFIG_TEST + if (data_buf_size != 0 && flag == DB_GET_BOTH) { + Tcl_SetResult(interp, + "Only one of -data_buf_size or -get_both can be specified.\n", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } + if (data_buf_size != 0 && mflag != 0) { + Tcl_SetResult(interp, + "Only one of -data_buf_size or -multi can be specified.\n", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } +#endif + if (useglob && flag == DB_GET_BOTH) { + Tcl_SetResult(interp, + "Only one of -glob or -get_both can be specified.\n", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } + + if (useglob) + pattern = Tcl_GetStringFromObj(objv[objc - 1], NULL); + + /* + * This is the list we return + */ + retlist = Tcl_NewListObj(0, NULL); + save.flags |= DB_DBT_MALLOC; + + /* + * isdup is used to know if we support duplicates. If not, we + * can just do a db->get call and avoid using cursors. + */ + if ((ret = dbp->get_flags(dbp, &isdup)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db get"); + goto out; + } + isdup &= DB_DUP; + + /* + * If the database doesn't support duplicates or we're performing + * ops that don't require returning multiple items, use DB->get + * instead of a cursor operation. + */ + if (pattern == NULL && (isdup == 0 || mflag != 0 || +#ifdef CONFIG_TEST + data_buf_size != 0 || +#endif + flag == DB_SET_RECNO || flag == DB_GET_BOTH || + flag == DB_CONSUME || flag == DB_CONSUME_WAIT)) { +#ifdef CONFIG_TEST + if (data_buf_size == 0) { + F_CLR(&save, DB_DBT_USERMEM); + F_SET(&save, DB_DBT_MALLOC); + } else { + (void)__os_malloc( + NULL, (size_t)data_buf_size, &save.data); + save.ulen = (u_int32_t)data_buf_size; + F_CLR(&save, DB_DBT_MALLOC); + F_SET(&save, DB_DBT_USERMEM); + } +#endif + if (flag == DB_GET_BOTH) { + if (userecno) { + 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], + &key.data, &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBGET(ret), "db get"); + goto out; + } + } + ktmp = key.data; + /* + * Already checked args above. Fill in key and save. + * Save is used in the dbp->get call below to fill in + * data. + * + * If the "data" here is really a primary key--that + * is, if we're in a pget--and that primary key + * is a recno, treat it appropriately as an int. + */ + if (useprecno) { + result = _GetUInt32(interp, + objv[objc - 1], &precno); + if (result == TCL_OK) { + save.data = &precno; + save.size = sizeof(db_recno_t); + } else + goto out; + } else { + ret = _CopyObjBytes(interp, objv[objc-1], + &dtmp, &save.size, &freedata); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBGET(ret), "db get"); + goto out; + } + save.data = dtmp; + } + } else if (flag != DB_CONSUME && flag != DB_CONSUME_WAIT) { + if (userecno) { + result = _GetUInt32( + interp, objv[(objc - 1)], &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-1], + &key.data, &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBGET(ret), "db get"); + goto out; + } + } + ktmp = key.data; +#ifdef CONFIG_TEST + if (mflag & DB_MULTIPLE) { + if ((ret = __os_malloc(dbp->env, + (size_t)bufsize, &save.data)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + goto out; + } + save.ulen = (u_int32_t)bufsize; + F_CLR(&save, DB_DBT_MALLOC); + F_SET(&save, DB_DBT_USERMEM); + } +#endif + } + + data = save; + + if (ispget) { + if (flag == DB_GET_BOTH) { + pkey.data = save.data; + pkey.size = save.size; + data.data = NULL; + data.size = 0; + } + F_SET(&pkey, DB_DBT_MALLOC); + _debug_check(); + ret = dbp->pget(dbp, + txn, &key, &pkey, &data, flag | rmw); + } else { + _debug_check(); + ret = dbp->get(dbp, + txn, &key, &data, flag | rmw | mflag); + } + result = _ReturnSetup(interp, ret, DB_RETOK_DBGET(ret), + "db get"); + if (ret == 0) { + /* + * Success. Return a list of the form {name value} + * If it was a recno in key.data, we need to convert + * into a string/object representation of that recno. + */ + if (mflag & DB_MULTIPLE) + result = _SetMultiList(interp, + retlist, &key, &data, type, flag); + else if (type == DB_RECNO || type == DB_QUEUE) + if (ispget) + result = _Set3DBTList(interp, + retlist, &key, 1, &pkey, + useprecno, &data); + else + result = _SetListRecnoElem(interp, + retlist, *(db_recno_t *)key.data, + data.data, data.size); + else { + if (ispget) + result = _Set3DBTList(interp, + retlist, &key, 0, &pkey, + useprecno, &data); + else + result = _SetListElem(interp, retlist, + key.data, key.size, + data.data, data.size); + } + } + /* + * Free space from DBT. + * + * If we set DB_DBT_MALLOC, we need to free the space if and + * only if we succeeded and if DB allocated anything (the + * pointer has changed from what we passed in). If + * DB_DBT_MALLOC is not set, this is a bulk get buffer, and + * needs to be freed no matter what. + */ + if (F_ISSET(&key, DB_DBT_MALLOC) && ret == 0 && + key.data != ktmp) + __os_ufree(dbp->env, key.data); + if (F_ISSET(&data, DB_DBT_MALLOC) && ret == 0 && + data.data != dtmp) + __os_ufree(dbp->env, data.data); + else if (!F_ISSET(&data, DB_DBT_MALLOC)) + __os_free(dbp->env, data.data); + if (ispget && ret == 0 && pkey.data != save.data) + __os_ufree(dbp->env, pkey.data); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); + goto out; + } + + if (userecno) { + result = _GetUInt32(interp, objv[(objc - 1)], &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-1], &key.data, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBGET(ret), "db get"); + return (result); + } + } + ktmp = key.data; + ret = dbp->cursor(dbp, txn, &dbc, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db cursor"); + if (result == TCL_ERROR) + goto out; + + /* + * At this point, we have a cursor, if we have a pattern, + * we go to the nearest one and step forward until we don't + * have any more that match the pattern prefix. If we have + * an exact key, we go to that key position, and step through + * all the duplicates. In either case we build up a list of + * the form {{key data} {key data}...} along the way. + */ + memset(&data, 0, sizeof(data)); + /* + * Restore any "partial" info we have saved. + */ + data = save; + if (pattern) { + /* + * Note, prefix is returned in new space. Must free it. + */ + ret = _GetGlobPrefix(pattern, &prefix); + if (ret) { + result = TCL_ERROR; + Tcl_SetResult(interp, + "Unable to allocate pattern space", TCL_STATIC); + goto out1; + } + key.data = prefix; + key.size = (u_int32_t)strlen(prefix); + /* + * If they give us an empty pattern string + * (i.e. -glob *), go through entire DB. + */ + if (strlen(prefix) == 0) + cflag = DB_FIRST; + else + cflag = DB_SET_RANGE; + } else + cflag = DB_SET; + if (ispget) { + _debug_check(); + F_SET(&pkey, DB_DBT_MALLOC); + ret = dbc->pget(dbc, &key, &pkey, &data, cflag | rmw); + } else { + _debug_check(); + ret = dbc->get(dbc, &key, &data, cflag | rmw); + } + result = _ReturnSetup(interp, ret, DB_RETOK_DBCGET(ret), + "db get (cursor)"); + if (result == TCL_ERROR) + goto out1; + if (pattern) { + if (ret == 0 && prefix != NULL && + memcmp(key.data, prefix, strlen(prefix)) != 0) { + /* + * Free space from DB_DBT_MALLOC + */ + __os_ufree(dbp->env, data.data); + goto out1; + } + cflag = DB_NEXT; + } else + cflag = DB_NEXT_DUP; + + while (ret == 0 && result == TCL_OK) { + /* + * Build up our {name value} sublist + */ + if (ispget) + result = _Set3DBTList(interp, retlist, &key, 0, + &pkey, useprecno, &data); + else + result = _SetListElem(interp, retlist, + key.data, key.size, data.data, data.size); + /* + * Free space from DB_DBT_MALLOC + */ + if (ispget) + __os_ufree(dbp->env, pkey.data); + __os_ufree(dbp->env, data.data); + if (result != TCL_OK) + break; + /* + * Append {name value} to return list + */ + memset(&key, 0, sizeof(key)); + memset(&pkey, 0, sizeof(pkey)); + memset(&data, 0, sizeof(data)); + /* + * Restore any "partial" info we have saved. + */ + data = save; + if (ispget) { + F_SET(&pkey, DB_DBT_MALLOC); + ret = dbc->pget(dbc, &key, &pkey, &data, cflag | rmw); + } else + ret = dbc->get(dbc, &key, &data, cflag | rmw); + if (ret == 0 && prefix != NULL && + memcmp(key.data, prefix, strlen(prefix)) != 0) { + /* + * Free space from DB_DBT_MALLOC + */ + __os_ufree(dbp->env, data.data); + break; + } + } +out1: + (void)dbc->close(dbc); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); +out: + /* + * _GetGlobPrefix(), the function which allocates prefix, works + * by copying and condensing another string. Thus prefix may + * have multiple nuls at the end, so we free using __os_free(). + */ + if (prefix != NULL) + __os_free(dbp->env, prefix); + if (dtmp != NULL && freedata) + __os_free(dbp->env, dtmp); + if (ktmp != NULL && freekey) + __os_free(dbp->env, ktmp); + return (result); +} + +/* + * tcl_db_delete -- + */ +static int +tcl_DbDelete(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbdelopts[] = { + "-consume", + "-glob", + "-multiple", + "-multiple_key", + "-txn", + NULL + }; + enum dbdelopts { + DBDEL_CONSUME, + DBDEL_GLOB, + DBDEL_MULTIPLE, + DBDEL_MULTIPLE_KEY, + DBDEL_TXN + }; + DBC *dbc; + DBT key, data; + DBTYPE type; + DB_TXN *txn; + Tcl_Obj **elemv; + void *dtmp, *ktmp, *ptr; + db_recno_t recno; + int dlen, elemc, freekey, i, j, klen, optindex, result, ret; + u_int32_t dflag, flag, multiflag; + char *arg, *pattern, *prefix, msg[MSG_SIZE]; + + result = TCL_OK; + freekey = 0; + dflag = 0; + multiflag = 0; + pattern = prefix = NULL; + txn = NULL; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-args? key"); + return (TCL_ERROR); + } + + dtmp = ktmp = NULL; + memset(&key, 0, sizeof(key)); + /* + * The first arg must be -glob, -txn or a list of keys. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbdelopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + /* + * If we don't have a -glob or -txn, then the remaining + * args must be exact keys. Reset the result so we + * don't get an errant error message if there is another + * error. + */ + if (IS_HELP(objv[i]) == TCL_OK) + return (TCL_OK); + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbdelopts)optindex) { + case DBDEL_TXN: + if (i == objc) { + /* + * Someone could conceivably have a key of + * the same name. So just break and use it. + */ + i--; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + txn = NAME_TO_TXN(arg); + if (txn == NULL) { + snprintf(msg, MSG_SIZE, + "Delete: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case DBDEL_GLOB: + /* + * Get the pattern. Get the prefix and use cursors to + * get all the data items. + */ + if (i == objc) { + /* + * Someone could conceivably have a key of + * the same name. So just break and use it. + */ + i--; + break; + } + pattern = Tcl_GetStringFromObj(objv[i++], NULL); + break; + case DBDEL_CONSUME: + FLAG_CHECK(dflag); + dflag = DB_CONSUME; + break; + case DBDEL_MULTIPLE: + FLAG_CHECK(multiflag); + multiflag |= DB_MULTIPLE; + break; + case DBDEL_MULTIPLE_KEY: + FLAG_CHECK(multiflag); + multiflag |= DB_MULTIPLE_KEY; + break; + } + if (result != TCL_OK) + break; + } + + if (result != TCL_OK) + goto out; + /* + * XXX + * For consistency with get, we have decided for the moment, to + * allow -glob, or one key, not many. The code was originally + * written to take many keys and we'll leave it that way, because + * tcl_DbGet may one day accept many disjoint keys to get, rather + * than one, and at that time we'd make delete be consistent. In + * any case, the code is already here and there is no need to remove, + * just check that we only have one arg left. + * + * If we have a pattern AND more keys to process, there is an error. + * Either we have some number of exact keys, or we have a pattern. + */ + if (pattern == NULL) { + if (i != (objc - 1)) { + Tcl_WrongNumArgs( + interp, 2, objv, "?args? -glob pattern | key"); + result = TCL_ERROR; + goto out; + } + } else { + if (i != objc) { + Tcl_WrongNumArgs( + interp, 2, objv, "?args? -glob pattern | key"); + result = TCL_ERROR; + goto out; + } + } + + /* + * If we have remaining args, they are all exact keys. Call + * DB->del on each of those keys. + * + * If it is a RECNO database, the key is a record number and must be + * setup up to contain a db_recno_t. Otherwise the key is a "string". + */ + (void)dbp->get_type(dbp, &type); + ret = 0; + while (i < objc && ret == 0) { + memset(&key, 0, sizeof(key)); + if (multiflag == DB_MULTIPLE) { + /* + * To work out how big a buffer is needed, we first + * need to find out the total length of the data and + * the number of data items (elemc). + */ + ktmp = Tcl_GetByteArrayFromObj(objv[i], &klen); + result = Tcl_ListObjGetElements(interp, objv[i++], + &elemc, &elemv); + if (result != TCL_OK) + return (result); + + memset(&key, 0, sizeof(key)); + key.ulen = DB_ALIGN((u_int32_t)klen + (u_int32_t)elemc + * sizeof(u_int32_t) * 2, 1024UL); + key.flags = DB_DBT_USERMEM | DB_DBT_BULK; + if ((ret = + __os_malloc(dbp->env, key.ulen, &key.data)) != 0) + return (ret); + freekey = 1; + + if (type == DB_RECNO || type == DB_QUEUE) { + DB_MULTIPLE_RECNO_WRITE_INIT(ptr, &key); + for (j = 0; j < elemc; j++) { + result = + _GetUInt32(interp, + elemv[j], &recno); + if (result != TCL_OK) + return (result); + DB_MULTIPLE_RECNO_WRITE_NEXT(ptr, + &key, recno, dtmp, 0); + DB_ASSERT(dbp->env, ptr != NULL); + } + } else { + DB_MULTIPLE_WRITE_INIT(ptr, &key); + for (j = 0; j < elemc; j++) { + ktmp = Tcl_GetByteArrayFromObj(elemv[j], + &klen); + DB_MULTIPLE_WRITE_NEXT(ptr, + &key, ktmp, (u_int32_t)klen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } + } else if (multiflag == DB_MULTIPLE_KEY) { + /* + * To work out how big a buffer is needed, we first + * need to find out the total length of the data (len) + * and the number of data items (elemc). + */ + ktmp = Tcl_GetByteArrayFromObj(objv[i], &klen); + result = Tcl_ListObjGetElements(interp, objv[i++], + &elemc, &elemv); + if (result != TCL_OK) + return (result); + + memset(&key, 0, sizeof(key)); + key.ulen = DB_ALIGN((u_int32_t)klen + + (u_int32_t)elemc * sizeof(u_int32_t) * 2, 1024UL); + key.flags = DB_DBT_USERMEM | DB_DBT_BULK; + if ((ret = + __os_malloc(dbp->env, key.ulen, &key.data)) != 0) + return (ret); + freekey = 1; + + if (type == DB_RECNO || type == DB_QUEUE) { + DB_MULTIPLE_RECNO_WRITE_INIT(ptr, &key); + for (j = 0; j + 1 < elemc; j += 2) { + result = + _GetUInt32(interp, + elemv[j], &recno); + if (result != TCL_OK) + return (result); + dtmp = Tcl_GetByteArrayFromObj( + elemv[j + 1], &dlen); + DB_MULTIPLE_RECNO_WRITE_NEXT(ptr, + &key, recno, dtmp, (u_int32_t)dlen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } else { + DB_MULTIPLE_WRITE_INIT(ptr, &key); + for (j = 0; j + 1 < elemc; j += 2) { + ktmp = Tcl_GetByteArrayFromObj( + elemv[j], &klen); + dtmp = Tcl_GetByteArrayFromObj( + elemv[j + 1], &dlen); + DB_MULTIPLE_KEY_WRITE_NEXT(ptr, + &key, ktmp, (u_int32_t)klen, + dtmp, (u_int32_t)dlen); + DB_ASSERT(dbp->env, ptr != NULL); + } + } + } else if (type == DB_RECNO || type == DB_QUEUE) { + result = _GetUInt32(interp, objv[i++], &recno); + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + ret = _CopyObjBytes(interp, objv[i++], &ktmp, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBDEL(ret), "db del"); + return (result); + } + key.data = ktmp; + } + _debug_check(); + ret = dbp->del(dbp, txn, &key, dflag | multiflag); + /* + * If we have any error, set up return result and stop + * processing keys. + */ + if (freekey && key.data != NULL) + __os_free(dbp->env, key.data); + if (ret != 0) + break; + } + result = _ReturnSetup(interp, ret, DB_RETOK_DBDEL(ret), "db del"); + + /* + * At this point we've either finished or, if we have a pattern, + * we go to the nearest one and step forward until we don't + * have any more that match the pattern prefix. + */ + if (pattern) { + ret = dbp->cursor(dbp, txn, &dbc, 0); + if (ret != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db cursor"); + goto out; + } + /* + * Note, prefix is returned in new space. Must free it. + */ + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + ret = _GetGlobPrefix(pattern, &prefix); + if (ret) { + result = TCL_ERROR; + Tcl_SetResult(interp, + "Unable to allocate pattern space", TCL_STATIC); + goto out; + } + key.data = prefix; + key.size = (u_int32_t)strlen(prefix); + if (strlen(prefix) == 0) + flag = DB_FIRST; + else + flag = DB_SET_RANGE; + ret = dbc->get(dbc, &key, &data, flag); + while (ret == 0 && + memcmp(key.data, prefix, strlen(prefix)) == 0) { + /* + * Each time through here the cursor is pointing + * at the current valid item. Delete it and + * move ahead. + */ + _debug_check(); + ret = dbc->del(dbc, dflag); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_DBCDEL(ret), "db c_del"); + break; + } + /* + * Deleted the current, now move to the next item + * in the list, check if it matches the prefix pattern. + */ + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + ret = dbc->get(dbc, &key, &data, DB_NEXT); + } + if (ret == DB_NOTFOUND) + ret = 0; + /* + * _GetGlobPrefix(), the function which allocates prefix, works + * by copying and condensing another string. Thus prefix may + * have multiple nuls at the end, so we free using __os_free(). + */ + __os_free(dbp->env, prefix); + (void)dbc->close(dbc); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db del"); + } +out: + return (result); +} + +/* + * tcl_db_cursor -- + */ +static int +tcl_DbCursor(interp, objc, objv, dbp, dbcp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ + DBC **dbcp; /* Return cursor pointer */ +{ + static const char *dbcuropts[] = { +#ifdef CONFIG_TEST + "-read_committed", + "-read_uncommitted", + "-update", +#endif + "-bulk", + "-txn", + NULL + }; + enum dbcuropts { +#ifdef CONFIG_TEST + DBCUR_READ_COMMITTED, + DBCUR_READ_UNCOMMITTED, + DBCUR_UPDATE, +#endif + DBCUR_BULK, + DBCUR_TXN + }; + DB_TXN *txn; + u_int32_t flag; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 0; + txn = NULL; + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbcuropts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto out; + } + i++; + switch ((enum dbcuropts)optindex) { +#ifdef CONFIG_TEST + case DBCUR_READ_COMMITTED: + flag |= DB_READ_COMMITTED; + break; + case DBCUR_READ_UNCOMMITTED: + flag |= DB_READ_UNCOMMITTED; + break; + case DBCUR_UPDATE: + flag |= DB_WRITECURSOR; + break; +#endif + case DBCUR_BULK: + flag |= DB_CURSOR_BULK; + break; + case DBCUR_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, + "Cursor: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + if (result != TCL_OK) + break; + } + if (result != TCL_OK) + goto out; + + _debug_check(); + ret = dbp->cursor(dbp, txn, dbcp, flag); + if (ret != 0) + result = _ErrorSetup(interp, ret, "db cursor"); +out: + return (result); +} + +/* + * tcl_DbAssociate -- + * Call DB->associate(). + */ +static int +tcl_DbAssociate(interp, objc, objv, dbp) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; + DB *dbp; +{ + static const char *dbaopts[] = { + "-create", + "-immutable_key", + "-txn", + NULL + }; + enum dbaopts { + DBA_CREATE, + DBA_IMMUTABLE_KEY, + DBA_TXN + }; + DB *sdbp; + DB_TXN *txn; + DBTCL_INFO *sdbip; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + u_int32_t flag; +#ifdef CONFIG_TEST + /* + * When calling DB->associate over RPC, the Tcl API uses + * special flags that the RPC server interprets to set the + * callback correctly. + */ + const char *cbname; + struct { + const char *name; + u_int32_t flag; + } *cb, callbacks[] = { + { "", 0 }, /* A NULL callback in Tcl. */ + { "_s_reversedata", DB_RPC2ND_REVERSEDATA }, + { "_s_noop", DB_RPC2ND_NOOP }, + { "_s_concatkeydata", DB_RPC2ND_CONCATKEYDATA }, + { "_s_concatdatakey", DB_RPC2ND_CONCATDATAKEY }, + { "_s_reverseconcat", DB_RPC2ND_REVERSECONCAT }, + { "_s_truncdata", DB_RPC2ND_TRUNCDATA }, + { "_s_reversedata", DB_RPC2ND_REVERSEDATA }, + { "_s_constant", DB_RPC2ND_CONSTANT }, + { "sj_getzip", DB_RPC2ND_GETZIP }, + { "sj_getname", DB_RPC2ND_GETNAME }, + { NULL, 0 } + }; +#endif + + txn = NULL; + result = TCL_OK; + flag = 0; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "[callback] secondary"); + return (TCL_ERROR); + } + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbaopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + if (result == TCL_OK) + return (result); + result = TCL_OK; + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbaopts)optindex) { + case DBA_CREATE: + flag |= DB_CREATE; + break; + case DBA_IMMUTABLE_KEY: + flag |= DB_IMMUTABLE_KEY; + break; + case DBA_TXN: + if (i > (objc - 1)) { + 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, + "Associate: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + } + if (result != TCL_OK) + return (result); + + /* + * Better be 1 or 2 args left. The last arg must be the sdb + * handle. If 2 args then objc-2 is the callback proc, else + * we have a NULL callback. + */ + /* Get the secondary DB handle. */ + arg = Tcl_GetStringFromObj(objv[objc - 1], NULL); + sdbp = NAME_TO_DB(arg); + if (sdbp == NULL) { + snprintf(msg, MSG_SIZE, + "Associate: Invalid database handle: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + + /* + * The callback is simply a Tcl object containing the name + * of the callback proc, which is the second-to-last argument. + * + * Note that the callback needs to go in the *secondary* DB handle's + * info struct; we may have multiple secondaries with different + * callbacks. + */ + sdbip = (DBTCL_INFO *)sdbp->api_internal; + +#ifdef CONFIG_TEST + if (i != objc - 1 && RPC_ON(dbp->dbenv)) { + /* + * The flag values allowed to DB->associate may have changed to + * overlap with the range we've chosen. If this happens, we + * need to reset all of the RPC_2ND_* flags to a new range. + */ + if ((flag & DB_RPC2ND_MASK) != 0) { + snprintf(msg, MSG_SIZE, + "RPC secondary flags overlap -- recalculate!\n"); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + + cbname = Tcl_GetStringFromObj(objv[objc - 2], NULL); + for (cb = callbacks; cb->name != NULL; cb++) + if (strcmp(cb->name, cbname) == 0) { + flag |= cb->flag; + break; + } + + if (cb->name == NULL) { + snprintf(msg, MSG_SIZE, + "Associate: unknown callback: %s\n", cbname); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + + ret = dbp->associate(dbp, txn, sdbp, NULL, flag); + + /* + * The primary reference isn't set when calling through + * the RPC server, but the Tcl API peeks at it in other + * places (see tcl_DbGet). + */ + if (ret == 0) + sdbp->s_primary = dbp; + } else if (i != objc - 1) { +#else + if (i != objc - 1) { +#endif + /* + * We have 2 args, get the callback. + */ + sdbip->i_second_call = objv[objc - 2]; + Tcl_IncrRefCount(sdbip->i_second_call); + + /* Now call associate. */ + _debug_check(); + ret = dbp->associate(dbp, txn, sdbp, tcl_second_call, flag); + } else { + /* + * We have a NULL callback. + */ + sdbip->i_second_call = NULL; + ret = dbp->associate(dbp, txn, sdbp, NULL, flag); + } + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "associate"); + + return (result); +} + +/* + * tcl_second_call -- + * Callback function for secondary indices. Get the callback + * out of ip->i_second_call and call it. + */ +static int +tcl_second_call(dbp, pkey, data, skey) + DB *dbp; + const DBT *pkey, *data; + DBT *skey; +{ + DBT *tskey; + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *pobj, *dobj, *objv[3], *robj, **skeylist; + size_t len; + int ilen, result, ret; + u_int32_t i, nskeys; + void *retbuf, *databuf; + + ip = (DBTCL_INFO *)dbp->api_internal; + interp = ip->i_interp; + objv[0] = ip->i_second_call; + + /* + * Create two ByteArray objects, with the contents of the pkey + * and data DBTs that are our inputs. + */ + pobj = Tcl_NewByteArrayObj(pkey->data, (int)pkey->size); + Tcl_IncrRefCount(pobj); + dobj = Tcl_NewByteArrayObj(data->data, (int)data->size); + Tcl_IncrRefCount(dobj); + + objv[1] = pobj; + objv[2] = dobj; + + result = Tcl_EvalObjv(interp, 3, objv, 0); + + Tcl_DecrRefCount(pobj); + Tcl_DecrRefCount(dobj); + + if (result != TCL_OK) { + __db_errx(dbp->env, + "Tcl callback function failed with code %d", result); + return (EINVAL); + } + + robj = Tcl_GetObjResult(interp); + if (robj->typePtr == NULL || strcmp(robj->typePtr->name, "list") != 0) { + nskeys = 1; + skeylist = &robj; + tskey = skey; + } else { + if ((result = Tcl_ListObjGetElements(interp, + robj, &ilen, &skeylist)) != TCL_OK) { + __db_errx(dbp->env, + "Could not get list elements from Tcl callback"); + return (EINVAL); + } + nskeys = (u_int32_t)ilen; + + /* + * It would be nice to check for nskeys == 0 and return + * DB_DONOTINDEX, but Tcl does not distinguish between an empty + * string and an empty list, so that would disallow empty + * secondary keys. + */ + if (nskeys == 0) { + nskeys = 1; + skeylist = &robj; + } + if (nskeys == 1) + tskey = skey; + else { + memset(skey, 0, sizeof(DBT)); + if ((ret = __os_umalloc(dbp->env, + nskeys * sizeof(DBT), &skey->data)) != 0) + return (ret); + skey->size = nskeys; + F_SET(skey, DB_DBT_MULTIPLE | DB_DBT_APPMALLOC); + tskey = (DBT *)skey->data; + } + } + + for (i = 0; i < nskeys; i++, tskey++) { + retbuf = Tcl_GetByteArrayFromObj(skeylist[i], &ilen); + len = (size_t)ilen; + + /* + * retbuf is owned by Tcl; copy it into malloc'ed memory. + * We need to use __os_umalloc rather than ufree because this + * will be freed by DB using __os_ufree--the DB_DBT_APPMALLOC + * flag tells DB to free application-allocated memory. + */ + if ((ret = __os_umalloc(dbp->env, len, &databuf)) != 0) + return (ret); + memcpy(databuf, retbuf, len); + + memset(tskey, 0, sizeof(DBT)); + tskey->data = databuf; + tskey->size = (u_int32_t)len; + F_SET(tskey, DB_DBT_APPMALLOC); + } + + return (0); +} + +/* + * tcl_db_join -- + */ +static int +tcl_DbJoin(interp, objc, objv, dbp, dbcp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ + DBC **dbcp; /* Cursor pointer */ +{ + static const char *dbjopts[] = { + "-nosort", + NULL + }; + enum dbjopts { + DBJ_NOSORT + }; + DBC **listp; + size_t size; + u_int32_t flag; + int adj, i, j, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 0; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "curs1 curs2 ..."); + return (TCL_ERROR); + } + + for (adj = i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbjopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + if (result == TCL_OK) + return (result); + result = TCL_OK; + Tcl_ResetResult(interp); + break; + } + switch ((enum dbjopts)optindex) { + case DBJ_NOSORT: + flag |= DB_JOIN_NOSORT; + adj++; + break; + } + } + if (result != TCL_OK) + return (result); + /* + * Allocate one more for NULL ptr at end of list. + */ + size = sizeof(DBC *) * (size_t)((objc - adj) + 1); + ret = __os_malloc(dbp->env, size, &listp); + if (ret != 0) { + Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); + return (TCL_ERROR); + } + + memset(listp, 0, size); + for (j = 0, i = adj; i < objc; i++, j++) { + arg = Tcl_GetStringFromObj(objv[i], NULL); + listp[j] = NAME_TO_DBC(arg); + if (listp[j] == NULL) { + snprintf(msg, MSG_SIZE, + "Join: Invalid cursor: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + goto out; + } + } + listp[j] = NULL; + _debug_check(); + ret = dbp->join(dbp, listp, dbcp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db join"); + +out: + __os_free(dbp->env, listp); + return (result); +} + +/* + * tcl_db_getjoin -- + */ +static int +tcl_DbGetjoin(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbgetjopts[] = { +#ifdef CONFIG_TEST + "-nosort", +#endif + "-txn", + NULL + }; + enum dbgetjopts { +#ifdef CONFIG_TEST + DBGETJ_NOSORT, +#endif + DBGETJ_TXN + }; + DB_TXN *txn; + DB *elemdbp; + DBC **listp; + DBC *dbc; + DBT key, data; + Tcl_Obj **elemv, *retlist; + void *ktmp; + size_t size; + u_int32_t flag; + int adj, elemc, freekey, i, j, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 0; + ktmp = NULL; + freekey = 0; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "{db1 key1} {db2 key2} ..."); + return (TCL_ERROR); + } + + txn = NULL; + i = 2; + adj = i; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbgetjopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + if (result == TCL_OK) + return (result); + result = TCL_OK; + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbgetjopts)optindex) { +#ifdef CONFIG_TEST + case DBGETJ_NOSORT: + flag |= DB_JOIN_NOSORT; + adj++; + break; +#endif + case DBGETJ_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); + adj += 2; + if (txn == NULL) { + snprintf(msg, MSG_SIZE, + "GetJoin: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + } + if (result != TCL_OK) + return (result); + size = sizeof(DBC *) * (size_t)((objc - adj) + 1); + ret = __os_malloc(NULL, size, &listp); + if (ret != 0) { + Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); + return (TCL_ERROR); + } + + memset(listp, 0, size); + for (j = 0, i = adj; i < objc; i++, j++) { + /* + * Get each sublist as {db key} + */ + result = Tcl_ListObjGetElements(interp, objv[i], + &elemc, &elemv); + if (elemc != 2) { + Tcl_SetResult(interp, "Lists must be {db key}", + TCL_STATIC); + result = TCL_ERROR; + goto out; + } + /* + * Get a pointer to that open db. Then, open a cursor in + * that db, and go to the "key" place. + */ + elemdbp = NAME_TO_DB(Tcl_GetStringFromObj(elemv[0], NULL)); + if (elemdbp == NULL) { + snprintf(msg, MSG_SIZE, "Get_join: Invalid db: %s\n", + Tcl_GetStringFromObj(elemv[0], NULL)); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + goto out; + } + ret = elemdbp->cursor(elemdbp, txn, &listp[j], 0); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db cursor")) == TCL_ERROR) + goto out; + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + ret = _CopyObjBytes(interp, elemv[elemc-1], &ktmp, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "db join"); + goto out; + } + key.data = ktmp; + ret = (listp[j])->get(listp[j], &key, &data, DB_SET); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_DBCGET(ret), + "db cget")) == TCL_ERROR) + goto out; + } + listp[j] = NULL; + _debug_check(); + ret = dbp->join(dbp, listp, &dbc, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db join"); + if (result == TCL_ERROR) + goto out; + + retlist = Tcl_NewListObj(0, NULL); + while (ret == 0 && result == TCL_OK) { + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + key.flags |= DB_DBT_MALLOC; + data.flags |= DB_DBT_MALLOC; + ret = dbc->get(dbc, &key, &data, 0); + /* + * Build up our {name value} sublist + */ + if (ret == 0) { + result = _SetListElem(interp, retlist, + key.data, key.size, + data.data, data.size); + __os_ufree(dbp->env, key.data); + __os_ufree(dbp->env, data.data); + } + } + (void)dbc->close(dbc); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); +out: + if (ktmp != NULL && freekey) + __os_free(dbp->env, ktmp); + while (j) { + if (listp[j]) + (void)(listp[j])->close(listp[j]); + j--; + } + __os_free(dbp->env, listp); + return (result); +} + +/* + * tcl_DbGetFlags -- + */ +static int +tcl_DbGetFlags(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + int i, ret, result; + u_int32_t flags; + char buf[512]; + Tcl_Obj *res; + + static const struct { + u_int32_t flag; + char *arg; + } db_flags[] = { + { DB_CHKSUM, "-chksum" }, + { DB_DUP, "-dup" }, + { DB_DUPSORT, "-dupsort" }, + { DB_ENCRYPT, "-encrypt" }, + { DB_INORDER, "-inorder" }, + { DB_TXN_NOT_DURABLE, "-notdurable" }, + { DB_RECNUM, "-recnum" }, + { DB_RENUMBER, "-renumber" }, + { DB_REVSPLITOFF, "-revsplitoff" }, + { DB_SNAPSHOT, "-snapshot" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + ret = dbp->get_flags(dbp, &flags); + if ((result = _ReturnSetup( + interp, ret, DB_RETOK_STD(ret), "db get_flags")) == TCL_OK) { + buf[0] = '\0'; + + for (i = 0; db_flags[i].flag != 0; i++) + if (LF_ISSET(db_flags[i].flag)) { + if (strlen(buf) > 0) + (void)strncat(buf, " ", sizeof(buf)); + (void)strncat( + buf, db_flags[i].arg, sizeof(buf)); + } + + res = NewStringObj(buf, strlen(buf)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * tcl_DbGetOpenFlags -- + */ +static int +tcl_DbGetOpenFlags(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + int i, ret, result; + u_int32_t flags; + char buf[512]; + Tcl_Obj *res; + + static const struct { + u_int32_t flag; + char *arg; + } open_flags[] = { + { DB_AUTO_COMMIT, "-auto_commit" }, + { DB_CREATE, "-create" }, + { DB_EXCL, "-excl" }, + { DB_MULTIVERSION, "-multiversion" }, + { DB_NOMMAP, "-nommap" }, + { DB_RDONLY, "-rdonly" }, + { DB_READ_UNCOMMITTED, "-read_uncommitted" }, + { DB_THREAD, "-thread" }, + { DB_TRUNCATE, "-truncate" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + ret = dbp->get_open_flags(dbp, &flags); + if ((result = _ReturnSetup( + interp, ret, DB_RETOK_STD(ret), "db get_open_flags")) == TCL_OK) { + buf[0] = '\0'; + + for (i = 0; open_flags[i].flag != 0; i++) + if (LF_ISSET(open_flags[i].flag)) { + if (strlen(buf) > 0) + (void)strncat(buf, " ", sizeof(buf)); + (void)strncat( + buf, open_flags[i].arg, sizeof(buf)); + } + + res = NewStringObj(buf, strlen(buf)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * tcl_DbCount -- + */ +static int +tcl_DbCount(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + DBC *dbc; + DBT key, data; + Tcl_Obj *res; + void *ktmp; + db_recno_t count, recno; + int freekey, result, ret; + + res = NULL; + count = 0; + freekey = ret = 0; + ktmp = NULL; + result = TCL_OK; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "key"); + return (TCL_ERROR); + } + + /* + * Get the count for our key. + * We do this by getting a cursor for this DB. Moving the cursor + * to the set location, and getting a count on that cursor. + */ + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + + /* + * If it's a queue or recno database, we must make sure to + * treat the key as a recno rather than as a byte string. + */ + if (dbp->type == DB_RECNO || dbp->type == DB_QUEUE) { + result = _GetUInt32(interp, objv[2], &recno); + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + ret = _CopyObjBytes(interp, objv[2], &ktmp, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "db count"); + return (result); + } + key.data = ktmp; + } + _debug_check(); + ret = dbp->cursor(dbp, NULL, &dbc, 0); + if (ret != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db cursor"); + goto out; + } + /* + * Move our cursor to the key. + */ + ret = dbc->get(dbc, &key, &data, DB_SET); + if (ret == DB_KEYEMPTY || ret == DB_NOTFOUND) + count = 0; + else { + ret = dbc->count(dbc, &count, 0); + if (ret != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db c count"); + goto out; + } + } + res = Tcl_NewWideIntObj((Tcl_WideInt)count); + Tcl_SetObjResult(interp, res); + +out: if (ktmp != NULL && freekey) + __os_free(dbp->env, ktmp); + (void)dbc->close(dbc); + return (result); +} + +#ifdef CONFIG_TEST +/* + * tcl_DbKeyRange -- + */ +static int +tcl_DbKeyRange(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbkeyropts[] = { + "-txn", + NULL + }; + enum dbkeyropts { + DBKEYR_TXN + }; + DB_TXN *txn; + DB_KEY_RANGE range; + DBT key; + DBTYPE type; + Tcl_Obj *myobjv[3], *retlist; + void *ktmp; + db_recno_t recno; + u_int32_t flag; + int freekey, i, myobjc, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + ktmp = NULL; + flag = 0; + freekey = 0; + result = TCL_OK; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-txn id? key"); + return (TCL_ERROR); + } + + txn = NULL; + for (i = 2; i < objc;) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbkeyropts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + if (result == TCL_OK) + return (result); + result = TCL_OK; + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbkeyropts)optindex) { + case DBKEYR_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, + "KeyRange: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + } + if (result != TCL_OK) + return (result); + (void)dbp->get_type(dbp, &type); + ret = 0; + /* + * Make sure we have a key. + */ + if (i != (objc - 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? key"); + result = TCL_ERROR; + goto out; + } + memset(&key, 0, sizeof(key)); + if (type == DB_RECNO || type == DB_QUEUE) { + result = _GetUInt32(interp, objv[i], &recno); + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + ret = _CopyObjBytes(interp, objv[i++], &ktmp, + &key.size, &freekey); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "db keyrange"); + return (result); + } + key.data = ktmp; + } + _debug_check(); + ret = dbp->key_range(dbp, txn, &key, &range, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db keyrange"); + if (result == TCL_ERROR) + goto out; + + /* + * If we succeeded, set up return list. + */ + myobjc = 3; + myobjv[0] = Tcl_NewDoubleObj(range.less); + myobjv[1] = Tcl_NewDoubleObj(range.equal); + myobjv[2] = Tcl_NewDoubleObj(range.greater); + retlist = Tcl_NewListObj(myobjc, myobjv); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); + +out: if (ktmp != NULL && freekey) + __os_free(dbp->env, ktmp); + return (result); +} +#endif + +/* + * tcl_DbTruncate -- + */ +static int +tcl_DbTruncate(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbcuropts[] = { + "-txn", + NULL + }; + enum dbcuropts { + DBTRUNC_TXN + }; + DB_TXN *txn; + Tcl_Obj *res; + u_int32_t count; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + txn = NULL; + result = TCL_OK; + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbcuropts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto out; + } + i++; + switch ((enum dbcuropts)optindex) { + case DBTRUNC_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, + "Truncate: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + } + if (result != TCL_OK) + break; + } + if (result != TCL_OK) + goto out; + + _debug_check(); + ret = dbp->truncate(dbp, txn, &count, 0); + if (ret != 0) + result = _ErrorSetup(interp, ret, "db truncate"); + + else { + res = Tcl_NewWideIntObj((Tcl_WideInt)count); + Tcl_SetObjResult(interp, res); + } +out: + return (result); +} + +#ifdef CONFIG_TEST +/* + * tcl_DbCompact -- + */ +static int +tcl_DbCompact(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + static const char *dbcuropts[] = { + "-fillpercent", + "-freespace", + "-freeonly", + "-pages", + "-start", + "-stop", + "-timeout", + "-txn", + NULL + }; + enum dbcuropts { + DBREORG_FILLFACTOR, + DBREORG_FREESPACE, + DBREORG_FREEONLY, + DBREORG_PAGES, + DBREORG_START, + DBREORG_STOP, + DBREORG_TIMEOUT, + DBREORG_TXN + }; + DBTCL_INFO *ip; + DBT *key, end, start, stop; + DBTYPE type; + DB_TXN *txn; + Tcl_Obj *myobj, *retlist; + db_recno_t recno, srecno; + u_int32_t arg, fillfactor, flags, pages, timeout; + char *carg, msg[MSG_SIZE]; + int freekey, i, optindex, result, ret; + void *kp; + + flags = 0; + result = TCL_OK; + txn = NULL; + (void)dbp->get_type(dbp, &type); + memset(&start, 0, sizeof(start)); + memset(&stop, 0, sizeof(stop)); + memset(&end, 0, sizeof(end)); + ip = (DBTCL_INFO *)dbp->api_internal; + fillfactor = pages = timeout = 0; + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbcuropts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto out; + } + i++; + switch ((enum dbcuropts)optindex) { + case DBREORG_FILLFACTOR: + if (i == objc) { + Tcl_WrongNumArgs(interp, + 2, objv, "?-fillfactor number?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &arg); + if (result != TCL_OK) + goto out; + i++; + fillfactor = arg; + break; + case DBREORG_FREESPACE: + LF_SET(DB_FREE_SPACE); + break; + + case DBREORG_FREEONLY: + LF_SET(DB_FREELIST_ONLY); + break; + + case DBREORG_PAGES: + if (i == objc) { + Tcl_WrongNumArgs(interp, + 2, objv, "?-pages number?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &arg); + if (result != TCL_OK) + goto out; + i++; + pages = arg; + break; + case DBREORG_TIMEOUT: + if (i == objc) { + Tcl_WrongNumArgs(interp, + 2, objv, "?-timeout number?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &arg); + if (result != TCL_OK) + goto out; + i++; + timeout = arg; + break; + + case DBREORG_START: + case DBREORG_STOP: + if (i == objc) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-args? -start/stop key"); + result = TCL_ERROR; + goto out; + } + if ((enum dbcuropts)optindex == DBREORG_START) { + key = &start; + key->data = &recno; + } else { + key = &stop; + key->data = &srecno; + } + if (type == DB_RECNO || type == DB_QUEUE) { + result = _GetUInt32( + interp, objv[i], key->data); + if (result == TCL_OK) { + key->size = sizeof(db_recno_t); + } else + goto out; + } else { + ret = _CopyObjBytes(interp, objv[i], + &key->data, &key->size, &freekey); + if (ret != 0) + goto err; + if (freekey == 0) { + if ((ret = __os_malloc(NULL, + key->size, &kp)) != 0) + goto err; + + memcpy(kp, key->data, key->size); + key->data = kp; + key->ulen = key->size; + } + } + i++; + break; + case DBREORG_TXN: + if (i == objc) { + Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?"); + result = TCL_ERROR; + break; + } + carg = Tcl_GetStringFromObj(objv[i++], NULL); + txn = NAME_TO_TXN(carg); + if (txn == NULL) { + snprintf(msg, MSG_SIZE, + "Compact: Invalid txn: %s\n", carg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + } + if (result != TCL_OK) + break; + } + if (result != TCL_OK) + goto out; + + if (ip->i_cdata == NULL) + if ((ret = __os_calloc(dbp->env, + 1, sizeof(DB_COMPACT), &ip->i_cdata)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + goto out; + } + + ip->i_cdata->compact_fillpercent = fillfactor; + ip->i_cdata->compact_timeout = timeout; + ip->i_cdata->compact_pages = pages; + + _debug_check(); + ret = dbp->compact(dbp, txn, &start, &stop, ip->i_cdata, flags, &end); + result = _ReturnSetup(interp, ret, DB_RETOK_DBCGET(ret), "dbp compact"); + if (result == TCL_ERROR) + goto out; + + retlist = Tcl_NewListObj(0, NULL); + if (ret != 0) + goto out; + if (type == DB_RECNO || type == DB_QUEUE) { + if (end.size == 0) + recno = 0; + else + recno = *((db_recno_t *)end.data); + myobj = Tcl_NewWideIntObj((Tcl_WideInt)recno); + } else + myobj = Tcl_NewByteArrayObj(end.data, (int)end.size); + result = Tcl_ListObjAppendElement(interp, retlist, myobj); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); + + if (0) { +err: result = _ReturnSetup(interp, + ret, DB_RETOK_DBCGET(ret), "dbc compact"); + } +out: + if (start.data != NULL && start.data != &recno) + __os_free(NULL, start.data); + if (stop.data != NULL && stop.data != &srecno) + __os_free(NULL, stop.data); + if (end.data != NULL) + __os_free(NULL, end.data); + + return (result); +} + +/* + * tcl_DbCompactStat + */ +static int +tcl_DbCompactStat(interp, objc, objv, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB *dbp; /* Database pointer */ +{ + DBTCL_INFO *ip; + + COMPQUIET(objc, 0); + COMPQUIET(objv, NULL); + + ip = (DBTCL_INFO *)dbp->api_internal; + + return (tcl_CompactStat(interp, ip)); +} + +/* + * PUBLIC: int tcl_CompactStat __P((Tcl_Interp *, DBTCL_INFO *)); + */ +int +tcl_CompactStat(interp, ip) + Tcl_Interp *interp; /* Interpreter */ + DBTCL_INFO *ip; +{ + DB_COMPACT *rp; + Tcl_Obj *res; + int result; + char msg[MSG_SIZE]; + + result = TCL_OK; + rp = NULL; + + _debug_check(); + if ((rp = ip->i_cdata) == NULL) { + snprintf(msg, MSG_SIZE, + "Compact stat: No stats available\n"); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + goto error; + } + + res = Tcl_NewObj(); + + MAKE_STAT_LIST("Pages freed", rp->compact_pages_free); + MAKE_STAT_LIST("Pages truncated", rp->compact_pages_truncated); + MAKE_STAT_LIST("Pages examined", rp->compact_pages_examine); + MAKE_STAT_LIST("Levels removed", rp->compact_levels); + MAKE_STAT_LIST("Deadlocks encountered", rp->compact_deadlock); + + Tcl_SetObjResult(interp, res); +error: + return (result); +} +#endif diff --git a/tcl/tcl_db_pkg.c b/tcl/tcl_db_pkg.c new file mode 100644 index 0000000..76543f4 --- /dev/null +++ b/tcl/tcl_db_pkg.c @@ -0,0 +1,4398 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#include "db_config.h" + +#ifdef CONFIG_TEST +#define DB_DBM_HSEARCH 1 +#endif + +#include "db_int.h" +#ifdef HAVE_SYSTEM_INCLUDE_FILES +#include <tcl.h> +#endif +#include "dbinc/db_page.h" +#include "dbinc/hash.h" +#include "dbinc/tcl_db.h" + +/* XXX we must declare global data in just one place */ +DBTCL_GLOBAL __dbtcl_global; + +/* + * Prototypes for procedures defined later in this file: + */ +static int berkdb_Cmd __P((ClientData, Tcl_Interp *, int, + Tcl_Obj * CONST*)); +static int bdb_EnvOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + DBTCL_INFO *, DB_ENV **)); +static int bdb_DbOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + DBTCL_INFO *, DB **)); +static int bdb_DbRemove __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); +static int bdb_DbRename __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); +static int bdb_Version __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); + +#ifdef HAVE_64BIT_TYPES +static int bdb_SeqOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + DBTCL_INFO *, DB_SEQUENCE **)); +#endif + +#ifdef CONFIG_TEST +static int bdb_DbUpgrade __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); +static int bdb_DbVerify __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + DBTCL_INFO *)); +static int bdb_GetConfig __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); +static int bdb_Handles __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); +static int bdb_MsgType __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); + +static int tcl_bt_compare __P((DB *, const DBT *, const DBT *)); +static int tcl_compare_callback __P((DB *, const DBT *, const DBT *, + Tcl_Obj *, char *)); +static void tcl_db_free __P((void *)); +static void * tcl_db_malloc __P((size_t)); +static void * tcl_db_realloc __P((void *, size_t)); +static int tcl_dup_compare __P((DB *, const DBT *, const DBT *)); +static u_int32_t tcl_h_hash __P((DB *, const void *, u_int32_t)); +static int tcl_isalive __P((DB_ENV *, pid_t, db_threadid_t, u_int32_t)); +static u_int32_t tcl_part_callback __P((DB *, DBT *)); +static int tcl_set_partition_dirs + __P((Tcl_Interp *, DB *, Tcl_Obj *)); +static int tcl_set_partition_keys + __P((Tcl_Interp *, DB *, Tcl_Obj *, DBT **)); +#endif + +int Db_tcl_Init __P((Tcl_Interp *)); + +/* + * Db_tcl_Init -- + * + * This is a package initialization procedure, which is called by Tcl when + * this package is to be added to an interpreter. The name is based on the + * name of the shared library, currently libdb_tcl-X.Y.so, which Tcl uses + * to determine the name of this function. + */ +int +Db_tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + char pkg[12]; + + snprintf(pkg, sizeof(pkg), "%d.%d", DB_VERSION_MAJOR, DB_VERSION_MINOR); + code = Tcl_PkgProvide(interp, "Db_tcl", pkg); + if (code != TCL_OK) + return (code); + + /* + * Don't allow setuid/setgid scripts for the Tcl API because some Tcl + * functions evaluate the arguments and could otherwise allow a user + * to inject Tcl commands. + */ +#if defined(HAVE_SETUID) && defined(HAVE_GETUID) + (void)setuid(getuid()); +#endif +#if defined(HAVE_SETGID) && defined(HAVE_GETGID) + (void)setgid(getgid()); +#endif + + (void)Tcl_CreateObjCommand(interp, + "berkdb", (Tcl_ObjCmdProc *)berkdb_Cmd, (ClientData)0, NULL); + /* + * Create shared global debugging variables + */ + (void)Tcl_LinkVar( + interp, "__debug_on", (char *)&__debug_on, TCL_LINK_INT); + (void)Tcl_LinkVar( + interp, "__debug_print", (char *)&__debug_print, TCL_LINK_INT); + (void)Tcl_LinkVar( + interp, "__debug_stop", (char *)&__debug_stop, TCL_LINK_INT); + (void)Tcl_LinkVar( + interp, "__debug_test", (char *)&__debug_test, + TCL_LINK_INT); + LIST_INIT(&__db_infohead); + return (TCL_OK); +} + +/* + * berkdb_cmd -- + * Implements the "berkdb" command. + * This command supports three sub commands: + * berkdb version - Returns a list {major minor patch} + * berkdb env - Creates a new DB_ENV and returns a binding + * to a new command of the form dbenvX, where X is an + * integer starting at 0 (dbenv0, dbenv1, ...) + * berkdb open - Creates a new DB (optionally within + * the given environment. Returns a binding to a new + * command of the form dbX, where X is an integer + * starting at 0 (db0, db1, ...) + */ +static int +berkdb_Cmd(notused, interp, objc, objv) + ClientData notused; /* Not used. */ + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *berkdbcmds[] = { +#ifdef CONFIG_TEST + "dbverify", + "getconfig", + "handles", + "msgtype", + "upgrade", +#endif + "dbremove", + "dbrename", + "env", + "envremove", + "open", +#ifdef HAVE_64BIT_TYPES + "sequence", +#endif + "version", +#ifdef CONFIG_TEST + /* All below are compatibility functions */ + "hcreate", "hsearch", "hdestroy", + "dbminit", "fetch", "store", + "delete", "firstkey", "nextkey", + "ndbm_open", "dbmclose", +#endif + /* All below are convenience functions */ + "rand", "random_int", "srand", + "debug_check", + NULL + }; + /* + * All commands enums below ending in X are compatibility + */ + enum berkdbcmds { +#ifdef CONFIG_TEST + BDB_DBVERIFY, + BDB_GETCONFIG, + BDB_HANDLES, + BDB_MSGTYPE, + BDB_UPGRADE, +#endif + BDB_DBREMOVE, + BDB_DBRENAME, + BDB_ENV, + BDB_ENVREMOVE, + BDB_OPEN, +#ifdef HAVE_64BIT_TYPES + BDB_SEQUENCE, +#endif + BDB_VERSION, +#ifdef CONFIG_TEST + BDB_HCREATEX, BDB_HSEARCHX, BDB_HDESTROYX, + BDB_DBMINITX, BDB_FETCHX, BDB_STOREX, + BDB_DELETEX, BDB_FIRSTKEYX, BDB_NEXTKEYX, + BDB_NDBMOPENX, BDB_DBMCLOSEX, +#endif + BDB_RANDX, BDB_RAND_INTX, BDB_SRANDX, + BDB_DBGCKX + }; + static int env_id = 0; + static int db_id = 0; +#ifdef HAVE_64BIT_TYPES + static int seq_id = 0; +#endif + + DB *dbp; +#ifdef HAVE_64BIT_TYPES + DB_SEQUENCE *seq; +#endif +#ifdef CONFIG_TEST + DBM *ndbmp; + static int ndbm_id = 0; +#endif + DBTCL_INFO *ip; + DB_ENV *dbenv; + Tcl_Obj *res; + int cmdindex, result; + char newname[MSG_SIZE]; + + COMPQUIET(notused, NULL); + + Tcl_ResetResult(interp); + memset(newname, 0, MSG_SIZE); + result = TCL_OK; + if (objc <= 1) { + Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs"); + return (TCL_ERROR); + } + + /* + * Get the command name index from the object based on the berkdbcmds + * defined above. + */ + if (Tcl_GetIndexFromObj(interp, + objv[1], berkdbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) + return (IS_HELP(objv[1])); + res = NULL; + switch ((enum berkdbcmds)cmdindex) { +#ifdef CONFIG_TEST + case BDB_DBVERIFY: + snprintf(newname, sizeof(newname), "db%d", db_id); + ip = _NewInfo(interp, NULL, newname, I_DB); + if (ip != NULL) { + result = bdb_DbVerify(interp, objc, objv, ip); + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + result = TCL_ERROR; + } + break; + case BDB_GETCONFIG: + result = bdb_GetConfig(interp, objc, objv); + break; + case BDB_HANDLES: + result = bdb_Handles(interp, objc, objv); + break; + case BDB_MSGTYPE: + result = bdb_MsgType(interp, objc, objv); + break; + case BDB_UPGRADE: + result = bdb_DbUpgrade(interp, objc, objv); + break; +#endif + case BDB_VERSION: + _debug_check(); + result = bdb_Version(interp, objc, objv); + break; + case BDB_ENV: + snprintf(newname, sizeof(newname), "env%d", env_id); + ip = _NewInfo(interp, NULL, newname, I_ENV); + if (ip != NULL) { + result = bdb_EnvOpen(interp, objc, objv, ip, &dbenv); + if (result == TCL_OK && dbenv != NULL) { + env_id++; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)env_Cmd, + (ClientData)dbenv, NULL); + /* Use ip->i_name - newname is overwritten */ + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, dbenv); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + result = TCL_ERROR; + } + break; + case BDB_DBREMOVE: + result = bdb_DbRemove(interp, objc, objv); + break; + case BDB_DBRENAME: + result = bdb_DbRename(interp, objc, objv); + break; + case BDB_ENVREMOVE: + result = tcl_EnvRemove(interp, objc, objv, NULL, NULL); + break; + case BDB_OPEN: + snprintf(newname, sizeof(newname), "db%d", db_id); + ip = _NewInfo(interp, NULL, newname, I_DB); + if (ip != NULL) { + result = bdb_DbOpen(interp, objc, objv, ip, &dbp); + if (result == TCL_OK && dbp != NULL) { + db_id++; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)db_Cmd, + (ClientData)dbp, NULL); + /* Use ip->i_name - newname is overwritten */ + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, dbp); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + result = TCL_ERROR; + } + break; +#ifdef HAVE_64BIT_TYPES + case BDB_SEQUENCE: + snprintf(newname, sizeof(newname), "seq%d", seq_id); + ip = _NewInfo(interp, NULL, newname, I_SEQ); + if (ip != NULL) { + result = bdb_SeqOpen(interp, objc, objv, ip, &seq); + if (result == TCL_OK && seq != NULL) { + seq_id++; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)seq_Cmd, + (ClientData)seq, NULL); + /* Use ip->i_name - newname is overwritten */ + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, seq); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + result = TCL_ERROR; + } + break; +#endif +#ifdef CONFIG_TEST + case BDB_HCREATEX: + case BDB_HSEARCHX: + case BDB_HDESTROYX: + result = bdb_HCommand(interp, objc, objv); + break; + case BDB_DBMINITX: + case BDB_DBMCLOSEX: + case BDB_FETCHX: + case BDB_STOREX: + case BDB_DELETEX: + case BDB_FIRSTKEYX: + case BDB_NEXTKEYX: + result = bdb_DbmCommand(interp, objc, objv, DBTCL_DBM, NULL); + break; + case BDB_NDBMOPENX: + snprintf(newname, sizeof(newname), "ndbm%d", ndbm_id); + ip = _NewInfo(interp, NULL, newname, I_NDBM); + if (ip != NULL) { + result = bdb_NdbmOpen(interp, objc, objv, &ndbmp); + if (result == TCL_OK) { + ndbm_id++; + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)ndbm_Cmd, + (ClientData)ndbmp, NULL); + /* Use ip->i_name - newname is overwritten */ + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(ip, ndbmp); + } else + _DeleteInfo(ip); + } else { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + result = TCL_ERROR; + } + break; +#endif + case BDB_RANDX: + case BDB_RAND_INTX: + case BDB_SRANDX: + result = bdb_RandCommand(interp, objc, objv); + break; + case BDB_DBGCKX: + _debug_check(); + res = Tcl_NewIntObj(0); + break; + } + /* + * For each different arg call different function to create + * new commands (or if version, get/return it). + */ + if (result == TCL_OK && res != NULL) + Tcl_SetObjResult(interp, res); + return (result); +} + +/* + * bdb_EnvOpen - + * Implements the environment open command. + * There are many, many options to the open command. + * Here is the general flow: + * + * 1. Call db_env_create to create the env handle. + * 2. Parse args tracking options. + * 3. Make any pre-open setup calls necessary. + * 4. Call DB_ENV->open to open the env. + * 5. Return env widget handle to user. + */ +static int +bdb_EnvOpen(interp, objc, objv, ip, dbenvp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBTCL_INFO *ip; /* Our internal info */ + DB_ENV **dbenvp; /* Environment pointer */ +{ + static const char *envopen[] = { +#ifdef CONFIG_TEST + "-alloc", + "-auto_commit", + "-cdb", + "-cdb_alldb", + "-client_timeout", + "-event", + "-failchk", + "-isalive", + "-lock", + "-lock_conflict", + "-lock_detect", + "-lock_max_locks", + "-lock_max_lockers", + "-lock_max_objects", + "-lock_partitions", + "-lock_timeout", + "-log", + "-log_filemode", + "-log_buffer", + "-log_inmemory", + "-log_max", + "-log_regionmax", + "-log_remove", + "-mpool_max_openfd", + "-mpool_max_write", + "-mpool_mmap_size", + "-mpool_nommap", + "-multiversion", + "-mutex_set_align", + "-mutex_set_incr", + "-mutex_set_max", + "-mutex_set_tas_spins", + "-overwrite", + "-pagesize", + "-register", + "-reg_timeout", + "-region_init", + "-rep", + "-rep_client", + "-rep_inmem_files", + "-rep_lease", + "-rep_master", + "-rep_transport", + "-server", + "-server_timeout", + "-set_intermediate_dir_mode", + "-snapshot", + "-tablesize", + "-thread", + "-time_notgranted", + "-txn_nowait", + "-txn_timeout", + "-txn_timestamp", + "-verbose", + "-wrnosync", + "-zero_log", +#endif + "-add_dir", + "-cachesize", + "-cache_max", + "-create", + "-create_dir", + "-data_dir", + "-encryptaes", + "-encryptany", + "-errfile", + "-errpfx", + "-home", + "-log_dir", + "-mode", + "-private", + "-recover", + "-recover_fatal", + "-shm_key", + "-system_mem", + "-tmp_dir", + "-txn", + "-txn_max", + "-use_environ", + "-use_environ_root", + NULL + }; + /* + * !!! + * These have to be in the same order as the above, + * which is close to but not quite alphabetical. + */ + enum envopen { +#ifdef CONFIG_TEST + TCL_ENV_ALLOC, + TCL_ENV_AUTO_COMMIT, + TCL_ENV_CDB, + TCL_ENV_CDB_ALLDB, + TCL_ENV_CLIENT_TO, + TCL_ENV_EVENT, + TCL_ENV_FAILCHK, + TCL_ENV_ISALIVE, + TCL_ENV_LOCK, + TCL_ENV_CONFLICT, + TCL_ENV_DETECT, + TCL_ENV_LOCK_MAX_LOCKS, + TCL_ENV_LOCK_MAX_LOCKERS, + TCL_ENV_LOCK_MAX_OBJECTS, + TCL_ENV_LOCK_PARTITIONS, + TCL_ENV_LOCK_TIMEOUT, + TCL_ENV_LOG, + TCL_ENV_LOG_FILEMODE, + TCL_ENV_LOG_BUFFER, + TCL_ENV_LOG_INMEMORY, + TCL_ENV_LOG_MAX, + TCL_ENV_LOG_REGIONMAX, + TCL_ENV_LOG_REMOVE, + TCL_ENV_MPOOL_MAX_OPENFD, + TCL_ENV_MPOOL_MAX_WRITE, + TCL_ENV_MPOOL_MMAP_SIZE, + TCL_ENV_MPOOL_NOMMAP, + TCL_ENV_MULTIVERSION, + TCL_ENV_MUTSETALIGN, + TCL_ENV_MUTSETINCR, + TCL_ENV_MUTSETMAX, + TCL_ENV_MUTSETTAS, + TCL_ENV_OVERWRITE, + TCL_ENV_PAGESIZE, + TCL_ENV_REGISTER, + TCL_ENV_REG_TIMEOUT, + TCL_ENV_REGION_INIT, + TCL_ENV_REP, + TCL_ENV_REP_CLIENT, + TCL_ENV_REP_INMEM_FILES, + TCL_ENV_REP_LEASE, + TCL_ENV_REP_MASTER, + TCL_ENV_REP_TRANSPORT, + TCL_ENV_SERVER, + TCL_ENV_SERVER_TO, + TCL_ENV_SET_INTERMEDIATE_DIR, + TCL_ENV_SNAPSHOT, + TCL_ENV_TABLESIZE, + TCL_ENV_THREAD, + TCL_ENV_TIME_NOTGRANTED, + TCL_ENV_TXN_NOWAIT, + TCL_ENV_TXN_TIMEOUT, + TCL_ENV_TXN_TIME, + TCL_ENV_VERBOSE, + TCL_ENV_WRNOSYNC, + TCL_ENV_ZEROLOG, +#endif + TCL_ENV_ADD_DIR, + TCL_ENV_CACHESIZE, + TCL_ENV_CACHE_MAX, + TCL_ENV_CREATE, + TCL_ENV_CREATE_DIR, + TCL_ENV_DATA_DIR, + TCL_ENV_ENCRYPT_AES, + TCL_ENV_ENCRYPT_ANY, + TCL_ENV_ERRFILE, + TCL_ENV_ERRPFX, + TCL_ENV_HOME, + TCL_ENV_LOG_DIR, + TCL_ENV_MODE, + TCL_ENV_PRIVATE, + TCL_ENV_RECOVER, + TCL_ENV_RECOVER_FATAL, + TCL_ENV_SHM_KEY, + TCL_ENV_SYSTEM_MEM, + TCL_ENV_TMP_DIR, + TCL_ENV_TXN, + TCL_ENV_TXN_MAX, + TCL_ENV_USE_ENVIRON, + TCL_ENV_USE_ENVIRON_ROOT + }; + DB_ENV *dbenv; + Tcl_Obj **myobjv; + u_int32_t cr_flags, gbytes, bytes, logbufset, logmaxset; + u_int32_t open_flags, rep_flags, set_flags, uintarg; + int i, mode, myobjc, ncaches, optindex, result, ret; + long client_to, server_to, shm; + char *arg, *home, *passwd, *server; +#ifdef CONFIG_TEST + Tcl_Obj **myobjv1; + time_t timestamp; + long v; + u_int32_t detect, time_flag; + u_int8_t *conflicts; + int intarg, intarg2, j, nmodes, temp; +#endif + + result = TCL_OK; + mode = 0; + rep_flags = set_flags = cr_flags = 0; + home = NULL; + + /* + * XXX + * If/when our Tcl interface becomes thread-safe, we should enable + * DB_THREAD here in all cases. For now, we turn it on later in this + * function, and only when we're in testing and we specify the + * -thread flag, so that we can exercise MUTEX_THREAD_LOCK cases. + * + * In order to become truly thread-safe, we need to look at making sure + * DBTCL_INFO structs are safe to share across threads (they're not + * mutex-protected) before we declare the Tcl interface thread-safe. + * Meanwhile, there's no strong reason to enable DB_THREAD when not + * testing. + */ + open_flags = 0; + logmaxset = logbufset = 0; + + if (objc <= 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + + /* + * Server code must go before the call to db_env_create. + */ + server = NULL; + server_to = client_to = 0; + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i++], envopen, "option", + TCL_EXACT, &optindex) != TCL_OK) { + Tcl_ResetResult(interp); + continue; + } +#ifdef CONFIG_TEST + switch ((enum envopen)optindex) { + case TCL_ENV_SERVER: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-server hostname"); + result = TCL_ERROR; + break; + } + FLD_SET(cr_flags, DB_RPCCLIENT); + server = Tcl_GetStringFromObj(objv[i++], NULL); + break; + case TCL_ENV_SERVER_TO: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-server_to secs"); + result = TCL_ERROR; + break; + } + FLD_SET(cr_flags, DB_RPCCLIENT); + result = Tcl_GetLongFromObj(interp, objv[i++], + &server_to); + break; + case TCL_ENV_CLIENT_TO: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-client_to secs"); + result = TCL_ERROR; + break; + } + FLD_SET(cr_flags, DB_RPCCLIENT); + result = Tcl_GetLongFromObj(interp, objv[i++], + &client_to); + break; + default: + break; + } +#endif + } + if (result != TCL_OK) + return (TCL_ERROR); + if ((ret = db_env_create(&dbenv, cr_flags)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_env_create")); + *dbenvp = dbenv; + + /* + * From here on we must 'goto error' in order to clean up the + * dbenv from db_env_create. + */ + dbenv->set_errpfx(dbenv, ip->i_name); + dbenv->set_errcall(dbenv, _ErrorFunc); + if (server != NULL && + (ret = dbenv->set_rpc_server(dbenv, NULL, server, + client_to, server_to, 0)) != 0) { + result = TCL_ERROR; + goto error; + } + + /* Hang our info pointer on the dbenv handle, so we can do callbacks. */ + dbenv->app_private = ip; + + /* + * Get the command name index from the object based on the bdbcmds + * defined above. + */ + i = 2; + while (i < objc) { + Tcl_ResetResult(interp); + if (Tcl_GetIndexFromObj(interp, objv[i], envopen, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto error; + } + i++; + switch ((enum envopen)optindex) { +#ifdef CONFIG_TEST + case TCL_ENV_SERVER: + case TCL_ENV_SERVER_TO: + case TCL_ENV_CLIENT_TO: + /* + * Already handled these, skip them and their arg. + */ + i++; + break; + case TCL_ENV_ALLOC: + /* + * Use a Tcl-local alloc and free function so that + * we're sure to test whether we use umalloc/ufree in + * the right places. + */ + (void)dbenv->set_alloc(dbenv, + tcl_db_malloc, tcl_db_realloc, tcl_db_free); + break; + case TCL_ENV_AUTO_COMMIT: + FLD_SET(set_flags, DB_AUTO_COMMIT); + break; + case TCL_ENV_CDB: + FLD_SET(open_flags, DB_INIT_CDB | DB_INIT_MPOOL); + break; + case TCL_ENV_CDB_ALLDB: + FLD_SET(set_flags, DB_CDB_ALLDB); + break; + case TCL_ENV_EVENT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-event eventproc"); + result = TCL_ERROR; + break; + } + result = tcl_EventNotify(interp, dbenv, objv[i++], ip); + break; + case TCL_ENV_FAILCHK: + FLD_SET(open_flags, DB_FAILCHK); + break; + case TCL_ENV_ISALIVE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-isalive aliveproc"); + result = TCL_ERROR; + break; + } + + ip->i_isalive = objv[i++]; + Tcl_IncrRefCount(ip->i_isalive); + _debug_check(); + /* Choose an arbitrary thread count, for testing. */ + if ((ret = dbenv->set_thread_count(dbenv, 5)) == 0) + ret = dbenv->set_isalive(dbenv, tcl_isalive); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_isalive"); + break; + case TCL_ENV_LOCK: + FLD_SET(open_flags, DB_INIT_LOCK | DB_INIT_MPOOL); + break; + case TCL_ENV_CONFLICT: + /* + * Get conflict list. List is: + * {nmodes {matrix}} + * + * Where matrix must be nmodes*nmodes big. + * Set up conflicts array to pass. + */ + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-lock_conflict {nmodes {matrix}}?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, myobjv[0], &nmodes); + if (result != TCL_OK) + break; + result = Tcl_ListObjGetElements(interp, myobjv[1], + &myobjc, &myobjv1); + if (myobjc != (nmodes * nmodes)) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-lock_conflict {nmodes {matrix}}?"); + result = TCL_ERROR; + break; + } + + ret = __os_malloc(dbenv->env, sizeof(u_int8_t) * + (size_t)nmodes * (size_t)nmodes, &conflicts); + if (ret != 0) { + result = TCL_ERROR; + break; + } + for (j = 0; j < myobjc; j++) { + result = Tcl_GetIntFromObj(interp, myobjv1[j], + &temp); + conflicts[j] = temp; + if (result != TCL_OK) { + __os_free(NULL, conflicts); + break; + } + } + _debug_check(); + ret = dbenv->set_lk_conflicts(dbenv, + (u_int8_t *)conflicts, nmodes); + __os_free(NULL, conflicts); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_lk_conflicts"); + break; + case TCL_ENV_DETECT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-lock_detect policy?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(arg, "default") == 0) + detect = DB_LOCK_DEFAULT; + else if (strcmp(arg, "expire") == 0) + detect = DB_LOCK_EXPIRE; + else if (strcmp(arg, "maxlocks") == 0) + detect = DB_LOCK_MAXLOCKS; + else if (strcmp(arg, "maxwrites") == 0) + detect = DB_LOCK_MAXWRITE; + else if (strcmp(arg, "minlocks") == 0) + detect = DB_LOCK_MINLOCKS; + else if (strcmp(arg, "minwrites") == 0) + detect = DB_LOCK_MINWRITE; + else if (strcmp(arg, "oldest") == 0) + detect = DB_LOCK_OLDEST; + else if (strcmp(arg, "youngest") == 0) + detect = DB_LOCK_YOUNGEST; + else if (strcmp(arg, "random") == 0) + detect = DB_LOCK_RANDOM; + else { + Tcl_AddErrorInfo(interp, + "lock_detect: illegal policy"); + result = TCL_ERROR; + break; + } + _debug_check(); + ret = dbenv->set_lk_detect(dbenv, detect); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "lock_detect"); + break; + case TCL_ENV_LOCK_MAX_LOCKS: + case TCL_ENV_LOCK_MAX_LOCKERS: + case TCL_ENV_LOCK_MAX_OBJECTS: + case TCL_ENV_LOCK_PARTITIONS: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-lock_max max?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + switch ((enum envopen)optindex) { + case TCL_ENV_LOCK_MAX_LOCKS: + ret = dbenv->set_lk_max_locks(dbenv, + uintarg); + break; + case TCL_ENV_LOCK_MAX_LOCKERS: + ret = dbenv->set_lk_max_lockers(dbenv, + uintarg); + break; + case TCL_ENV_LOCK_MAX_OBJECTS: + ret = dbenv->set_lk_max_objects(dbenv, + uintarg); + break; + case TCL_ENV_LOCK_PARTITIONS: + ret = dbenv->set_lk_partitions(dbenv, + uintarg); + break; + default: + break; + } + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "lock_max"); + } + break; + case TCL_ENV_MUTSETALIGN: + case TCL_ENV_MUTSETINCR: + case TCL_ENV_MUTSETMAX: + case TCL_ENV_MUTSETTAS: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-mutex_set val"); + result = TCL_ERROR; + break; + } + intarg = 0; + switch ((enum envopen)optindex) { + case TCL_ENV_MUTSETALIGN: + intarg = DBTCL_MUT_ALIGN; + break; + case TCL_ENV_MUTSETINCR: + intarg = DBTCL_MUT_INCR; + break; + case TCL_ENV_MUTSETMAX: + intarg = DBTCL_MUT_MAX; + break; + case TCL_ENV_MUTSETTAS: + intarg = DBTCL_MUT_TAS; + break; + default: + break; + } + result = tcl_MutSet(interp, objv[i++], dbenv, intarg); + break; + case TCL_ENV_TXN_NOWAIT: + FLD_SET(set_flags, DB_TXN_NOWAIT); + break; + case TCL_ENV_TXN_TIME: + case TCL_ENV_TXN_TIMEOUT: + case TCL_ENV_LOCK_TIMEOUT: + case TCL_ENV_REG_TIMEOUT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-xxx_timeout time?"); + result = TCL_ERROR; + break; + } + + if ((result = Tcl_GetLongFromObj( + interp, objv[i++], &v)) != TCL_OK) + break; + timestamp = (time_t)v; + + _debug_check(); + if ((enum envopen)optindex == TCL_ENV_TXN_TIME) + ret = + dbenv->set_tx_timestamp(dbenv, ×tamp); + else { + if ((enum envopen)optindex == + TCL_ENV_LOCK_TIMEOUT) + time_flag = DB_SET_LOCK_TIMEOUT; + else if ((enum envopen)optindex == + TCL_ENV_REG_TIMEOUT) + time_flag = DB_SET_REG_TIMEOUT; + else + time_flag = DB_SET_TXN_TIMEOUT; + + ret = dbenv->set_timeout(dbenv, + (db_timeout_t)timestamp, time_flag); + } + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "txn_timestamp"); + break; + case TCL_ENV_LOG: + FLD_SET(open_flags, DB_INIT_LOG | DB_INIT_MPOOL); + break; + case TCL_ENV_LOG_BUFFER: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_buffer size?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_lg_bsize(dbenv, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_bsize"); + logbufset = 1; + if (logmaxset) { + _debug_check(); + ret = dbenv->set_lg_max(dbenv, + logmaxset); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_max"); + logmaxset = 0; + logbufset = 0; + } + } + break; + case TCL_ENV_LOG_FILEMODE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_filemode mode?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_lg_filemode(dbenv, + (int)uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_filemode"); + } + break; + case TCL_ENV_LOG_INMEMORY: + ret = + dbenv->log_set_config(dbenv, DB_LOG_IN_MEMORY, 1); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_inmemory"); + break; + case TCL_ENV_LOG_MAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_max max?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK && logbufset) { + _debug_check(); + ret = dbenv->set_lg_max(dbenv, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_max"); + logbufset = 0; + } else + logmaxset = uintarg; + break; + case TCL_ENV_LOG_REGIONMAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_regionmax size?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_lg_regionmax(dbenv, uintarg); + result = + _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "log_regionmax"); + } + break; + case TCL_ENV_LOG_REMOVE: + ret = + dbenv->log_set_config(dbenv, DB_LOG_AUTO_REMOVE, 1); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "log_remove"); + break; + case TCL_ENV_MPOOL_MAX_OPENFD: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-mpool_max_openfd fd_count?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_mp_max_openfd(dbenv, intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "mpool_max_openfd"); + } + break; + case TCL_ENV_MPOOL_MAX_WRITE: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-mpool_max_write {nwrite nsleep}?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, myobjv[0], &intarg); + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[1], &intarg2); + if (result != TCL_OK) + break; + _debug_check(); + ret = dbenv->set_mp_max_write( + dbenv, intarg, (db_timeout_t)intarg2); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_mp_max_write"); + break; + case TCL_ENV_MPOOL_MMAP_SIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-mpool_mmap_size size?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_mp_mmapsize(dbenv, + (size_t)intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "mpool_mmap_size"); + } + break; + case TCL_ENV_MPOOL_NOMMAP: + FLD_SET(set_flags, DB_NOMMAP); + break; + case TCL_ENV_MULTIVERSION: + FLD_SET(set_flags, DB_MULTIVERSION); + break; + case TCL_ENV_OVERWRITE: + FLD_SET(set_flags, DB_OVERWRITE); + break; + case TCL_ENV_PAGESIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-pagesize size?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_mp_pagesize(dbenv, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "pagesize"); + } + break; + case TCL_ENV_TABLESIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-tablesize size?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_mp_tablesize(dbenv, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "tablesize"); + } + break; + case TCL_ENV_REGISTER: + FLD_SET(open_flags, DB_REGISTER); + break; + case TCL_ENV_REGION_INIT: + _debug_check(); + ret = dbenv->set_flags(dbenv, DB_REGION_INIT, 1); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "region_init"); + break; + case TCL_ENV_SET_INTERMEDIATE_DIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-set_intermediate_dir_mode mode?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = dbenv->set_intermediate_dir_mode(dbenv, arg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_intermediate_dir_mode"); + break; + case TCL_ENV_REP: + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_REP_CLIENT: + rep_flags = DB_REP_CLIENT; + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_REP_MASTER: + rep_flags = DB_REP_MASTER; + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_REP_INMEM_FILES: + result = tcl_RepInmemFiles(interp,dbenv); + if (result == TCL_OK) + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_REP_LEASE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-rep_lease {nsites timeout clockskew}"); + result = TCL_ERROR; + break; + } + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + result = tcl_RepLease(interp, myobjc, myobjv, dbenv); + if (result == TCL_OK) + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_REP_TRANSPORT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-rep_transport {envid sendproc}"); + result = TCL_ERROR; + break; + } + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + result = tcl_RepTransport( + interp, myobjc, myobjv, dbenv, ip); + if (result == TCL_OK) + FLD_SET(open_flags, DB_INIT_REP); + break; + case TCL_ENV_SNAPSHOT: + FLD_SET(set_flags, DB_TXN_SNAPSHOT); + break; + case TCL_ENV_THREAD: + /* Enable DB_THREAD when specified in testing. */ + FLD_SET(open_flags, DB_THREAD); + break; + case TCL_ENV_TIME_NOTGRANTED: + FLD_SET(set_flags, DB_TIME_NOTGRANTED); + break; + case TCL_ENV_VERBOSE: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-verbose {which on|off}?"); + result = TCL_ERROR; + break; + } + result = tcl_EnvVerbose( + interp, dbenv, myobjv[0], myobjv[1]); + break; + case TCL_ENV_WRNOSYNC: + FLD_SET(set_flags, DB_TXN_WRITE_NOSYNC); + break; + case TCL_ENV_ZEROLOG: + if ((ret = + dbenv->log_set_config(dbenv, DB_LOG_ZERO, 1)) != 0) + return ( + _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_log_config")); + break; +#endif + case TCL_ENV_TXN: + FLD_SET(open_flags, DB_INIT_LOCK | + DB_INIT_LOG | DB_INIT_MPOOL | DB_INIT_TXN); + /* Make sure we have an arg to check against! */ + while (i < objc) { + arg = Tcl_GetStringFromObj(objv[i], NULL); + if (strcmp(arg, "nosync") == 0) { + FLD_SET(set_flags, DB_TXN_NOSYNC); + i++; + } else if (strcmp(arg, "snapshot") == 0) { + FLD_SET(set_flags, DB_TXN_SNAPSHOT); + i++; + } else + break; + } + break; + case TCL_ENV_CREATE: + FLD_SET(open_flags, DB_CREATE | DB_INIT_MPOOL); + break; + case TCL_ENV_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = dbenv->set_encrypt(dbenv, passwd, DB_ENCRYPT_AES); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + break; + case TCL_ENV_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = dbenv->set_encrypt(dbenv, passwd, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + break; + case TCL_ENV_HOME: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-home dir?"); + result = TCL_ERROR; + break; + } + home = Tcl_GetStringFromObj(objv[i++], NULL); + break; + case TCL_ENV_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 TCL_ENV_PRIVATE: + FLD_SET(open_flags, DB_PRIVATE | DB_INIT_MPOOL); + break; + case TCL_ENV_RECOVER: + FLD_SET(open_flags, DB_RECOVER); + break; + case TCL_ENV_RECOVER_FATAL: + FLD_SET(open_flags, DB_RECOVER_FATAL); + break; + case TCL_ENV_SYSTEM_MEM: + FLD_SET(open_flags, DB_SYSTEM_MEM); + break; + case TCL_ENV_USE_ENVIRON_ROOT: + FLD_SET(open_flags, DB_USE_ENVIRON_ROOT); + break; + case TCL_ENV_USE_ENVIRON: + FLD_SET(open_flags, DB_USE_ENVIRON); + break; + case TCL_ENV_CACHESIZE: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cachesize {gbytes bytes ncaches}?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, myobjv[0], &gbytes); + if (result != TCL_OK) + break; + result = _GetUInt32(interp, myobjv[1], &bytes); + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[2], &ncaches); + if (result != TCL_OK) + break; + _debug_check(); + ret = dbenv->set_cachesize(dbenv, gbytes, bytes, + ncaches); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_cachesize"); + break; + case TCL_ENV_CACHE_MAX: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cache_max {gbytes bytes}?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, myobjv[0], &gbytes); + if (result != TCL_OK) + break; + result = _GetUInt32(interp, myobjv[1], &bytes); + if (result != TCL_OK) + break; + _debug_check(); + ret = dbenv->set_cache_max(dbenv, gbytes, bytes); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_cache_max"); + break; + case TCL_ENV_SHM_KEY: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-shm_key key?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetLongFromObj(interp, objv[i++], &shm); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_shm_key(dbenv, shm); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "shm_key"); + } + break; + case TCL_ENV_TXN_MAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-txn_max max?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv->set_tx_max(dbenv, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "txn_max"); + } + break; + case TCL_ENV_ERRFILE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errfile file"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + tcl_EnvSetErrfile(interp, dbenv, ip, arg); + break; + case TCL_ENV_ERRPFX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errpfx prefix"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + result = tcl_EnvSetErrpfx(interp, dbenv, ip, arg); + break; + case TCL_ENV_DATA_DIR: + case TCL_ENV_ADD_DIR: + case TCL_ENV_CREATE_DIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-xxx_dir dir"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + switch ((enum envopen)optindex) { + case TCL_ENV_DATA_DIR: + ret = dbenv->set_data_dir(dbenv, arg); + break; + case TCL_ENV_ADD_DIR: + ret = dbenv->add_data_dir(dbenv, arg); + break; + case TCL_ENV_CREATE_DIR: + ret = dbenv->set_create_dir(dbenv, arg); + break; + default: + break; + } + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "xxx_dir"); + break; + case TCL_ENV_LOG_DIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-log_dir dir"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = dbenv->set_lg_dir(dbenv, arg); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_lg_dir"); + break; + case TCL_ENV_TMP_DIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-tmp_dir dir"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = dbenv->set_tmp_dir(dbenv, arg); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_tmp_dir"); + break; + } + /* + * If, at any time, parsing the args we get an error, + * bail out and return. + */ + if (result != TCL_OK) + goto error; + } + + /* + * We have to check this here. We want to set the log buffer + * size first, if it is specified. So if the user did so, + * then we took care of it above. But, if we get out here and + * logmaxset is non-zero, then they set the log_max without + * resetting the log buffer size, so we now have to do the + * call to set_lg_max, since we didn't do it above. + */ + if (logmaxset) { + _debug_check(); + ret = dbenv->set_lg_max(dbenv, (u_int32_t)logmaxset); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "log_max"); + } + + if (result != TCL_OK) + goto error; + + if (set_flags) { + ret = dbenv->set_flags(dbenv, set_flags, 1); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + if (result == TCL_ERROR) + goto error; + /* + * If we are successful, clear the result so that the + * return from set_flags isn't part of the result. + */ + Tcl_ResetResult(interp); + } + /* + * When we get here, we have already parsed all of our args + * and made all our calls to set up the environment. Everything + * is okay so far, no errors, if we get here. + * + * Now open the environment. + */ + _debug_check(); + ret = dbenv->open(dbenv, home, open_flags, mode); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "dbenv open"); + + if (rep_flags != 0 && result == TCL_OK) { + _debug_check(); + ret = dbenv->rep_start(dbenv, NULL, rep_flags); + result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "rep_start"); + } + +error: if (result == TCL_ERROR) { + if (ip->i_err && ip->i_err != stdout && ip->i_err != stderr) { + (void)fclose(ip->i_err); + ip->i_err = NULL; + } + (void)dbenv->close(dbenv, 0); + } + return (result); +} + +/* + * bdb_DbOpen -- + * Implements the "db_create/db_open" command. + * There are many, many options to the open command. + * Here is the general flow: + * + * 0. Preparse args to determine if we have -env. + * 1. Call db_create to create the db handle. + * 2. Parse args tracking options. + * 3. Make any pre-open setup calls necessary. + * 4. Call DB->open to open the database. + * 5. Return db widget handle to user. + */ +static int +bdb_DbOpen(interp, objc, objv, ip, dbp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBTCL_INFO *ip; /* Our internal info */ + DB **dbp; /* DB handle */ +{ + static const char *bdbenvopen[] = { + "-env", NULL + }; + enum bdbenvopen { + TCL_DB_ENV0 + }; + static const char *bdbopen[] = { +#ifdef CONFIG_TEST + "-btcompare", + "-dupcompare", + "-hashcompare", + "-hashproc", + "-lorder", + "-minkey", + "-nommap", + "-notdurable", + "-partition", + "-partition_dirs", + "-partition_callback", + "-read_uncommitted", + "-revsplitoff", + "-test", + "-thread", +#endif + "-auto_commit", + "-btree", + "-cachesize", + "-chksum", + "-compress", + "-create", + "-create_dir", + "-delim", + "-dup", + "-dupsort", + "-encrypt", + "-encryptaes", + "-encryptany", + "-env", + "-errfile", + "-errpfx", + "-excl", + "-extent", + "-ffactor", + "-hash", + "-inorder", + "-len", + "-maxsize", + "-mode", + "-multiversion", + "-nelem", + "-pad", + "-pagesize", + "-queue", + "-rdonly", + "-recno", + "-recnum", + "-renumber", + "-snapshot", + "-source", + "-truncate", + "-txn", + "-unknown", + "--", + NULL + }; + enum bdbopen { +#ifdef CONFIG_TEST + TCL_DB_BTCOMPARE, + TCL_DB_DUPCOMPARE, + TCL_DB_HASHCOMPARE, + TCL_DB_HASHPROC, + TCL_DB_LORDER, + TCL_DB_MINKEY, + TCL_DB_NOMMAP, + TCL_DB_NOTDURABLE, + TCL_DB_PARTITION, + TCL_DB_PART_DIRS, + TCL_DB_PART_CALLBACK, + TCL_DB_READ_UNCOMMITTED, + TCL_DB_REVSPLIT, + TCL_DB_TEST, + TCL_DB_THREAD, +#endif + TCL_DB_AUTO_COMMIT, + TCL_DB_BTREE, + TCL_DB_CACHESIZE, + TCL_DB_CHKSUM, + TCL_DB_COMPRESS, + TCL_DB_CREATE, + TCL_DB_CREATE_DIR, + TCL_DB_DELIM, + TCL_DB_DUP, + TCL_DB_DUPSORT, + TCL_DB_ENCRYPT, + TCL_DB_ENCRYPT_AES, + TCL_DB_ENCRYPT_ANY, + TCL_DB_ENV, + TCL_DB_ERRFILE, + TCL_DB_ERRPFX, + TCL_DB_EXCL, + TCL_DB_EXTENT, + TCL_DB_FFACTOR, + TCL_DB_HASH, + TCL_DB_INORDER, + TCL_DB_LEN, + TCL_DB_MAXSIZE, + TCL_DB_MODE, + TCL_DB_MULTIVERSION, + TCL_DB_NELEM, + TCL_DB_PAD, + TCL_DB_PAGESIZE, + TCL_DB_QUEUE, + TCL_DB_RDONLY, + TCL_DB_RECNO, + TCL_DB_RECNUM, + TCL_DB_RENUMBER, + TCL_DB_SNAPSHOT, + TCL_DB_SOURCE, + TCL_DB_TRUNCATE, + TCL_DB_TXN, + TCL_DB_UNKNOWN, + TCL_DB_ENDARG + }; + DBT *keys; + DBTCL_INFO *envip, *errip; + DBTYPE type; + DB_ENV *dbenv; + DB_TXN *txn; + ENV *env; + + Tcl_Obj **myobjv; + u_int32_t gbytes, bytes, open_flags, set_flags, uintarg; + int endarg, i, intarg, mode, myobjc, ncaches; + int optindex, result, ret, set_err, set_pfx, subdblen; + u_char *subdbtmp; + char *arg, *db, *passwd, *subdb, msg[MSG_SIZE]; + + type = DB_UNKNOWN; + endarg = mode = set_err = set_flags = set_pfx = 0; + result = TCL_OK; + subdbtmp = NULL; + keys = NULL; + db = subdb = NULL; + + /* + * XXX + * If/when our Tcl interface becomes thread-safe, we should enable + * DB_THREAD here in all cases. For now, we turn it on later in this + * function, and only when we're in testing and we specify the + * -thread flag, so that we can exercise MUTEX_THREAD_LOCK cases. + * + * In order to become truly thread-safe, we need to look at making sure + * DBTCL_INFO structs are safe to share across threads (they're not + * mutex-protected) before we declare the Tcl interface thread-safe. + * Meanwhile, there's no strong reason to enable DB_THREAD when not + * testing. + */ + open_flags = 0; + + dbenv = NULL; + txn = NULL; + env = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i++], bdbenvopen, + "option", TCL_EXACT, &optindex) != TCL_OK) { + /* + * Reset the result so we don't get + * an errant error message if there is another error. + */ + Tcl_ResetResult(interp); + continue; + } + switch ((enum bdbenvopen)optindex) { + case TCL_DB_ENV0: + arg = Tcl_GetStringFromObj(objv[i], NULL); + dbenv = NAME_TO_ENV(arg); + if (dbenv == NULL) { + Tcl_SetResult(interp, + "db open: illegal environment", TCL_STATIC); + return (TCL_ERROR); + } + } + break; + } + + /* + * Create the db handle before parsing the args + * since we'll be modifying the database options as we parse. + */ + ret = db_create(dbp, dbenv, 0); + if (ret) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_create")); + + /* Hang our info pointer on the DB handle, so we can do callbacks. */ + (*dbp)->api_internal = ip; + + /* + * XXX + * Remove restriction if error handling not tied to env. + * + * The DB->set_err* functions overwrite the environment. So, if + * we are using an env, don't overwrite it; if not using an env, + * then configure error handling. + */ + if (dbenv == NULL) { + env = NULL; + (*dbp)->set_errpfx((*dbp), ip->i_name); + (*dbp)->set_errcall((*dbp), _ErrorFunc); + } else + env = dbenv->env; + + /* + * If we are using an env, we keep track of err info in the env's ip. + * Otherwise use the DB's ip. + */ + envip = _PtrToInfo(dbenv); /* XXX */ + if (envip) + errip = envip; + else + errip = ip; + + /* + * Get the option name index from the object based on the args + * defined above. + */ + i = 2; + while (i < objc) { + Tcl_ResetResult(interp); + if (Tcl_GetIndexFromObj(interp, objv[i], bdbopen, "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 bdbopen)optindex) { +#ifdef CONFIG_TEST + case TCL_DB_BTCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-btcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * We don't need to crack it out now--we'll want + * to bundle it up to pass into Tcl_EvalObjv anyway. + * Tcl's object refcounting will--I hope--take care + * of the memory management here. + */ + ip->i_compare = objv[i++]; + Tcl_IncrRefCount(ip->i_compare); + _debug_check(); + ret = (*dbp)->set_bt_compare(*dbp, tcl_bt_compare); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_bt_compare"); + break; + case TCL_DB_DUPCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-dupcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * See TCL_DB_BTCOMPARE. + */ + ip->i_dupcompare = objv[i++]; + Tcl_IncrRefCount(ip->i_dupcompare); + _debug_check(); + ret = (*dbp)->set_dup_compare(*dbp, tcl_dup_compare); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_dup_compare"); + break; + case TCL_DB_HASHCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-hashcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * We don't need to crack it out now--we'll want + * to bundle it up to pass into Tcl_EvalObjv anyway. + * Tcl's object refcounting will--I hope--take care + * of the memory management here. + */ + ip->i_compare = objv[i++]; + Tcl_IncrRefCount(ip->i_compare); + _debug_check(); + ret = (*dbp)->set_h_compare(*dbp, tcl_bt_compare); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_h_compare"); + break; + case TCL_DB_HASHPROC: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-hashproc hashproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * See TCL_DB_BTCOMPARE. + */ + ip->i_hashproc = objv[i++]; + Tcl_IncrRefCount(ip->i_hashproc); + _debug_check(); + ret = (*dbp)->set_h_hash(*dbp, tcl_h_hash); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_h_hash"); + break; + case TCL_DB_LORDER: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-lorder 1234|4321"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_lorder(*dbp, intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_lorder"); + } + break; + case TCL_DB_MINKEY: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-minkey minkey"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_bt_minkey(*dbp, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_bt_minkey"); + } + break; + case TCL_DB_NOMMAP: + open_flags |= DB_NOMMAP; + break; + case TCL_DB_NOTDURABLE: + set_flags |= DB_TXN_NOT_DURABLE; + break; + case TCL_DB_PART_CALLBACK: + if (i + 1 >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-partition_callback numparts callback"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * See TCL_DB_BTCOMPARE. + */ + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result != TCL_OK) + break; + ip->i_part_callback = objv[i++]; + Tcl_IncrRefCount(ip->i_part_callback); + _debug_check(); + ret = (*dbp)->set_partition( + *dbp, uintarg, NULL, tcl_part_callback); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_partition_callback"); + break; + case TCL_DB_PART_DIRS: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-partition {dir list}"); + result = TCL_ERROR; + break; + } + ret = tcl_set_partition_dirs(interp, *dbp, objv[i++]); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_partition_dirs"); + break; + case TCL_DB_PARTITION: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-partition {key list}"); + result = TCL_ERROR; + break; + } + _debug_check(); + ret = tcl_set_partition_keys(interp, + *dbp, objv[i++], &keys); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_partition_keys"); + break; + case TCL_DB_READ_UNCOMMITTED: + open_flags |= DB_READ_UNCOMMITTED; + break; + case TCL_DB_REVSPLIT: + set_flags |= DB_REVSPLITOFF; + break; + case TCL_DB_TEST: + ret = (*dbp)->set_h_hash(*dbp, __ham_test); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_h_hash"); + break; + case TCL_DB_THREAD: + /* Enable DB_THREAD when specified in testing. */ + open_flags |= DB_THREAD; + break; +#endif + case TCL_DB_AUTO_COMMIT: + open_flags |= DB_AUTO_COMMIT; + break; + case TCL_DB_ENV: + /* + * Already parsed this, skip it and the env pointer. + */ + i++; + continue; + case TCL_DB_TXN: + if (i > (objc - 1)) { + 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, + "Open: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case TCL_DB_BTREE: + if (type != DB_UNKNOWN) { + Tcl_SetResult(interp, + "Too many DB types specified", TCL_STATIC); + result = TCL_ERROR; + goto error; + } + type = DB_BTREE; + break; + case TCL_DB_HASH: + if (type != DB_UNKNOWN) { + Tcl_SetResult(interp, + "Too many DB types specified", TCL_STATIC); + result = TCL_ERROR; + goto error; + } + type = DB_HASH; + break; + case TCL_DB_RECNO: + if (type != DB_UNKNOWN) { + Tcl_SetResult(interp, + "Too many DB types specified", TCL_STATIC); + result = TCL_ERROR; + goto error; + } + type = DB_RECNO; + break; + case TCL_DB_QUEUE: + if (type != DB_UNKNOWN) { + Tcl_SetResult(interp, + "Too many DB types specified", TCL_STATIC); + result = TCL_ERROR; + goto error; + } + type = DB_QUEUE; + break; + case TCL_DB_UNKNOWN: + if (type != DB_UNKNOWN) { + Tcl_SetResult(interp, + "Too many DB types specified", TCL_STATIC); + result = TCL_ERROR; + goto error; + } + break; + case TCL_DB_CREATE: + open_flags |= DB_CREATE; + break; + case TCL_DB_CREATE_DIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-create_dir dir"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = (*dbp)->set_create_dir(*dbp, arg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_create_dir"); + break; + case TCL_DB_EXCL: + open_flags |= DB_EXCL; + break; + case TCL_DB_RDONLY: + open_flags |= DB_RDONLY; + break; + case TCL_DB_TRUNCATE: + open_flags |= DB_TRUNCATE; + break; + case TCL_DB_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 TCL_DB_DUP: + set_flags |= DB_DUP; + break; + case TCL_DB_DUPSORT: + set_flags |= DB_DUPSORT; + break; + case TCL_DB_INORDER: + set_flags |= DB_INORDER; + break; + case TCL_DB_RECNUM: + set_flags |= DB_RECNUM; + break; + case TCL_DB_RENUMBER: + set_flags |= DB_RENUMBER; + break; + case TCL_DB_SNAPSHOT: + set_flags |= DB_SNAPSHOT; + break; + case TCL_DB_CHKSUM: + set_flags |= DB_CHKSUM; + break; + case TCL_DB_ENCRYPT: + set_flags |= DB_ENCRYPT; + break; + case TCL_DB_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = (*dbp)->set_encrypt(*dbp, passwd, DB_ENCRYPT_AES); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + break; + case TCL_DB_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = (*dbp)->set_encrypt(*dbp, passwd, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + break; + case TCL_DB_COMPRESS: + ret = (*dbp)->set_bt_compress(*dbp, 0, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_bt_compress"); + break; + case TCL_DB_FFACTOR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-ffactor density"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_h_ffactor(*dbp, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_h_ffactor"); + } + break; + case TCL_DB_MULTIVERSION: + open_flags |= DB_MULTIVERSION; + break; + case TCL_DB_NELEM: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-nelem nelem"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_h_nelem(*dbp, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_h_nelem"); + } + break; + case TCL_DB_DELIM: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-delim delim"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_re_delim(*dbp, intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_re_delim"); + } + break; + case TCL_DB_LEN: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-len length"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_re_len(*dbp, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_re_len"); + } + break; + case TCL_DB_MAXSIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-len length"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->mpf->set_maxsize( + (*dbp)->mpf, 0, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_maxsize"); + } + break; + case TCL_DB_PAD: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-pad pad"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_re_pad(*dbp, intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_re_pad"); + } + break; + case TCL_DB_SOURCE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-source file"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + _debug_check(); + ret = (*dbp)->set_re_source(*dbp, arg); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_re_source"); + break; + case TCL_DB_EXTENT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-extent size"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_q_extentsize(*dbp, uintarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_q_extentsize"); + } + break; + case TCL_DB_CACHESIZE: + result = Tcl_ListObjGetElements(interp, objv[i++], + &myobjc, &myobjv); + if (result != TCL_OK) + break; + if (myobjc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cachesize {gbytes bytes ncaches}?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, myobjv[0], &gbytes); + if (result != TCL_OK) + break; + result = _GetUInt32(interp, myobjv[1], &bytes); + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[2], &ncaches); + if (result != TCL_OK) + break; + _debug_check(); + ret = (*dbp)->set_cachesize(*dbp, gbytes, bytes, + ncaches); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set_cachesize"); + break; + case TCL_DB_PAGESIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-pagesize size?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_pagesize(*dbp, + (size_t)intarg); + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "set pagesize"); + } + break; + case TCL_DB_ERRFILE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errfile file"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + /* + * If the user already set one, close it. + */ + if (errip->i_err != NULL && + errip->i_err != stdout && errip->i_err != stderr) + (void)fclose(errip->i_err); + if (strcmp(arg, "/dev/stdout") == 0) + errip->i_err = stdout; + else if (strcmp(arg, "/dev/stderr") == 0) + errip->i_err = stderr; + else + errip->i_err = fopen(arg, "a"); + if (errip->i_err != NULL) { + _debug_check(); + (*dbp)->set_errfile(*dbp, errip->i_err); + set_err = 1; + } + break; + case TCL_DB_ERRPFX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errpfx prefix"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + /* + * If the user already set one, free it. + */ + if (errip->i_errpfx != NULL) + __os_free(NULL, errip->i_errpfx); + if ((ret = __os_strdup((*dbp)->env, + arg, &errip->i_errpfx)) != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "__os_strdup"); + break; + } + if (errip->i_errpfx != NULL) { + _debug_check(); + (*dbp)->set_errpfx(*dbp, errip->i_errpfx); + set_pfx = 1; + } + break; + case TCL_DB_ENDARG: + endarg = 1; + break; + } /* switch */ + + /* + * 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, 1 or 2 left) are + * file names. If we have 0, then an in-memory db. If + * there is 1, a db name, if 2 a db and subdb name. + */ + if (i != objc) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i != objc) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc(env, + (size_t)subdblen + 1, &subdb)) != 0) { + Tcl_SetResult(interp, db_strerror(ret), + TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + } + if (set_flags) { + ret = (*dbp)->set_flags(*dbp, set_flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + if (result == TCL_ERROR) + goto error; + /* + * If we are successful, clear the result so that the + * return from set_flags isn't part of the result. + */ + Tcl_ResetResult(interp); + } + + /* + * 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. + */ + _debug_check(); + + /* Open the database. */ + ret = (*dbp)->open(*dbp, txn, db, subdb, type, open_flags, mode); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db open"); + +error: + if (keys != NULL) + __os_free(NULL, keys); + if (subdb) + __os_free(env, subdb); + if (result == TCL_ERROR) { + (void)(*dbp)->close(*dbp, 0); + /* + * If we opened and set up the error file in the environment + * on this open, but we failed for some other reason, clean + * up and close the file. + * + * XXX when err stuff isn't tied to env, change to use ip, + * instead of envip. Also, set_err is irrelevant when that + * happens. It will just read: + * if (ip->i_err) + * fclose(ip->i_err); + */ + if (set_err && errip && errip->i_err != NULL && + errip->i_err != stdout && errip->i_err != stderr) { + (void)fclose(errip->i_err); + errip->i_err = NULL; + } + if (set_pfx && errip && errip->i_errpfx != NULL) { + __os_free(env, errip->i_errpfx); + errip->i_errpfx = NULL; + } + *dbp = NULL; + } + return (result); +} + +#ifdef HAVE_64BIT_TYPES +/* + * bdb_SeqOpen -- + * Implements the "Seq_create/Seq_open" command. + */ +static int +bdb_SeqOpen(interp, objc, objv, ip, seqp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBTCL_INFO *ip; /* Our internal info */ + DB_SEQUENCE **seqp; /* DB_SEQUENCE handle */ +{ + static const char *seqopen[] = { + "-cachesize", + "-create", + "-inc", + "-init", + "-dec", + "-max", + "-min", + "-thread", + "-txn", + "-wrap", + "--", + NULL + } ; + enum seqopen { + TCL_SEQ_CACHESIZE, + TCL_SEQ_CREATE, + TCL_SEQ_INC, + TCL_SEQ_INIT, + TCL_SEQ_DEC, + TCL_SEQ_MAX, + TCL_SEQ_MIN, + TCL_SEQ_THREAD, + TCL_SEQ_TXN, + TCL_SEQ_WRAP, + TCL_SEQ_ENDARG + }; + DB *dbp; + DBT key; + DBTYPE type; + DB_TXN *txn; + db_recno_t recno; + db_seq_t min, max, value; + Tcl_WideInt tcl_value; + u_int32_t flags, oflags; + int cache, endarg, i, optindex, result, ret, setrange, setvalue, v; + char *arg, *db, msg[MSG_SIZE]; + + COMPQUIET(ip, NULL); + COMPQUIET(value, 0); + *seqp = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + + txn = NULL; + endarg = 0; + flags = oflags = 0; + setrange = setvalue = 0; + min = INT64_MIN; + max = INT64_MAX; + cache = 0; + + for (i = 2; i < objc;) { + Tcl_ResetResult(interp); + if (Tcl_GetIndexFromObj(interp, objv[i], seqopen, "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++; + result = TCL_OK; + switch ((enum seqopen)optindex) { + case TCL_SEQ_CREATE: + oflags |= DB_CREATE; + break; + case TCL_SEQ_INC: + LF_SET(DB_SEQ_INC); + break; + case TCL_SEQ_CACHESIZE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cachesize value?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &cache); + break; + case TCL_SEQ_INIT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-init value?"); + result = TCL_ERROR; + break; + } + result = + Tcl_GetWideIntFromObj( + interp, objv[i++], &tcl_value); + value = tcl_value; + setvalue = 1; + break; + case TCL_SEQ_DEC: + LF_SET(DB_SEQ_DEC); + break; + case TCL_SEQ_MAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-max value?"); + result = TCL_ERROR; + break; + } + if ((result = + Tcl_GetWideIntFromObj(interp, + objv[i++], &tcl_value)) != TCL_OK) + goto error; + max = tcl_value; + setrange = 1; + break; + case TCL_SEQ_MIN: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-min value?"); + result = TCL_ERROR; + break; + } + if ((result = + Tcl_GetWideIntFromObj(interp, + objv[i++], &tcl_value)) != TCL_OK) + goto error; + min = tcl_value; + setrange = 1; + break; + case TCL_SEQ_THREAD: + oflags |= DB_THREAD; + break; + case TCL_SEQ_TXN: + if (i > (objc - 1)) { + 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, + "Sequence: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case TCL_SEQ_WRAP: + LF_SET(DB_SEQ_WRAP); + break; + case TCL_SEQ_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 (objc - i != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + /* + * The db must be a string but the sequence key may + * be anything. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if ((dbp = NAME_TO_DB(db)) == NULL) { + Tcl_SetResult(interp, "No such dbp", TCL_STATIC); + return (TCL_ERROR); + } + (void)dbp->get_type(dbp, &type); + + if (type == DB_QUEUE || type == DB_RECNO) { + result = _GetUInt32(interp, objv[i++], &recno); + if (result != TCL_OK) + return (result); + DB_INIT_DBT(key, &recno, sizeof(recno)); + } else + DB_INIT_DBT(key, Tcl_GetByteArrayFromObj(objv[i++], &v), v); + ret = db_sequence_create(seqp, dbp, 0); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence create")) != TCL_OK) { + *seqp = NULL; + return (result); + } + + ret = (*seqp)->set_flags(*seqp, flags); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence set_flags")) != TCL_OK) + goto error; + if (setrange) { + ret = (*seqp)->set_range(*seqp, min, max); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence set_range")) != TCL_OK) + goto error; + } + if (cache) { + ret = (*seqp)->set_cachesize(*seqp, cache); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence cachesize")) != TCL_OK) + goto error; + } + if (setvalue) { + ret = (*seqp)->initial_value(*seqp, value); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence init")) != TCL_OK) + goto error; + } + ret = (*seqp)->open(*seqp, txn, &key, oflags); + if ((result = _ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "sequence open")) != TCL_OK) + goto error; + + if (0) { +error: if (*seqp != NULL) + (void)(*seqp)->close(*seqp, 0); + *seqp = NULL; + } + return (result); +} +#endif + +/* + * bdb_DbRemove -- + * Implements the DB_ENV->remove and DB->remove command. + */ +static int +bdb_DbRemove(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *bdbrem[] = { + "-auto_commit", + "-encrypt", + "-encryptaes", + "-encryptany", + "-env", + "-txn", + "--", + NULL + }; + enum bdbrem { + TCL_DBREM_AUTOCOMMIT, + TCL_DBREM_ENCRYPT, + TCL_DBREM_ENCRYPT_AES, + TCL_DBREM_ENCRYPT_ANY, + TCL_DBREM_ENV, + TCL_DBREM_TXN, + TCL_DBREM_ENDARG + }; + DB *dbp; + DB_ENV *dbenv; + DB_TXN *txn; + ENV *env; + u_int32_t enc_flag, iflags, set_flags; + int endarg, i, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, msg[MSG_SIZE], *passwd, *subdb; + + dbp = NULL; + dbenv = NULL; + txn = NULL; + env = NULL; + enc_flag = iflags = set_flags = 0; + endarg = 0; + result = TCL_OK; + subdbtmp = NULL; + db = passwd = subdb = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], bdbrem, + "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 bdbrem)optindex) { + case TCL_DBREM_AUTOCOMMIT: + iflags |= DB_AUTO_COMMIT; + _debug_check(); + break; + case TCL_DBREM_ENCRYPT: + set_flags |= DB_ENCRYPT; + _debug_check(); + break; + case TCL_DBREM_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = DB_ENCRYPT_AES; + break; + case TCL_DBREM_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = 0; + break; + case TCL_DBREM_ENV: + arg = Tcl_GetStringFromObj(objv[i++], NULL); + dbenv = NAME_TO_ENV(arg); + if (dbenv == NULL) { + Tcl_SetResult(interp, + "db remove: illegal environment", + TCL_STATIC); + return (TCL_ERROR); + } + env = dbenv->env; + break; + case TCL_DBREM_ENDARG: + endarg = 1; + break; + case TCL_DBREM_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, + "Put: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + 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 1 or 2 left) are + * file names. If there is 1, a db name, if 2 a db and subdb name. + */ + if ((i != (objc - 1)) || (i != (objc - 2))) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i != objc) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc(env, (size_t)subdblen + 1, + &subdb)) != 0) { Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?"); + result = TCL_ERROR; + goto error; + } + if (dbenv == NULL) { + ret = db_create(&dbp, dbenv, 0); + if (ret) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_create"); + goto error; + } + + /* + * XXX + * Remove restriction if error handling not tied to env. + * + * The DB->set_err* functions overwrite the environment. So, if + * we are using an env, don't overwrite it; if not using an env, + * then configure error handling. + */ + dbp->set_errpfx(dbp, "DbRemove"); + dbp->set_errcall(dbp, _ErrorFunc); + + if (passwd != NULL) { + ret = dbp->set_encrypt(dbp, passwd, enc_flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + } + if (set_flags != 0) { + ret = dbp->set_flags(dbp, set_flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + } + } + + /* + * The dbremove method is a destructor, NULL out the dbp. + */ + _debug_check(); + if (dbp == NULL) + ret = dbenv->dbremove(dbenv, txn, db, subdb, iflags); + else + ret = dbp->remove(dbp, db, subdb, 0); + + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db remove"); + dbp = NULL; +error: + if (subdb) + __os_free(env, subdb); + if (result == TCL_ERROR && dbp != NULL) + (void)dbp->close(dbp, 0); + return (result); +} + +/* + * bdb_DbRename -- + * Implements the DB_ENV->dbrename and DB->rename commands. + */ +static int +bdb_DbRename(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *bdbmv[] = { + "-auto_commit", + "-encrypt", + "-encryptaes", + "-encryptany", + "-env", + "-txn", + "--", + NULL + }; + enum bdbmv { + TCL_DBMV_AUTOCOMMIT, + TCL_DBMV_ENCRYPT, + TCL_DBMV_ENCRYPT_AES, + TCL_DBMV_ENCRYPT_ANY, + TCL_DBMV_ENV, + TCL_DBMV_TXN, + TCL_DBMV_ENDARG + }; + DB *dbp; + DB_ENV *dbenv; + DB_TXN *txn; + ENV *env; + u_int32_t enc_flag, iflags, set_flags; + int endarg, i, newlen, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, msg[MSG_SIZE], *newname, *passwd, *subdb; + + dbp = NULL; + dbenv = NULL; + txn = NULL; + env = NULL; + enc_flag = iflags = set_flags = 0; + result = TCL_OK; + endarg = 0; + db = newname = passwd = subdb = NULL; + subdbtmp = NULL; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, + 3, objv, "?args? filename ?database? ?newname?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], bdbmv, + "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 bdbmv)optindex) { + case TCL_DBMV_AUTOCOMMIT: + iflags |= DB_AUTO_COMMIT; + _debug_check(); + break; + case TCL_DBMV_ENCRYPT: + set_flags |= DB_ENCRYPT; + _debug_check(); + break; + case TCL_DBMV_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = DB_ENCRYPT_AES; + break; + case TCL_DBMV_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = 0; + break; + case TCL_DBMV_ENV: + arg = Tcl_GetStringFromObj(objv[i++], NULL); + dbenv = NAME_TO_ENV(arg); + if (dbenv == NULL) { + Tcl_SetResult(interp, + "db rename: illegal environment", + TCL_STATIC); + return (TCL_ERROR); + } + env = dbenv->env; + break; + case TCL_DBMV_ENDARG: + endarg = 1; + break; + case TCL_DBMV_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, + "Put: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + 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 2 or 3 left) are + * file names. If there is 2, a file name, if 3 a file and db name. + */ + if ((i != (objc - 2)) || (i != (objc - 3))) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i == objc - 2) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc(env, + (size_t)subdblen + 1, &subdb)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &newlen); + if ((ret = __os_malloc( + env, (size_t)newlen + 1, &newname)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(newname, subdbtmp, (size_t)newlen); + newname[newlen] = '\0'; + } else { + Tcl_WrongNumArgs( + interp, 3, objv, "?args? filename ?database? ?newname?"); + result = TCL_ERROR; + goto error; + } + if (dbenv == NULL) { + ret = db_create(&dbp, dbenv, 0); + if (ret) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_create"); + goto error; + } + /* + * XXX + * Remove restriction if error handling not tied to env. + * + * The DB->set_err* functions overwrite the environment. So, if + * we are using an env, don't overwrite it; if not using an env, + * then configure error handling. + */ + dbp->set_errpfx(dbp, "DbRename"); + dbp->set_errcall(dbp, _ErrorFunc); + + if (passwd != NULL) { + ret = dbp->set_encrypt(dbp, passwd, enc_flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + } + if (set_flags != 0) { + ret = dbp->set_flags(dbp, set_flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + } + } + + /* + * The dbrename method is a destructor, NULL out the dbp. + */ + _debug_check(); + if (dbp == NULL) + ret = dbenv->dbrename(dbenv, txn, db, subdb, newname, iflags); + else + ret = dbp->rename(dbp, db, subdb, newname, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db rename"); + dbp = NULL; +error: + if (subdb) + __os_free(env, subdb); + if (newname) + __os_free(env, newname); + if (result == TCL_ERROR && dbp != NULL) + (void)dbp->close(dbp, 0); + return (result); +} + +#ifdef CONFIG_TEST +/* + * bdb_DbVerify -- + * Implements the DB->verify command. + */ +static int +bdb_DbVerify(interp, objc, objv, ip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBTCL_INFO *ip; /* Our internal info */ +{ + static const char *bdbverify[] = { + "-btcompare", + "-dupcompare", + "-hashcompare", + "-hashproc", + + "-encrypt", + "-encryptaes", + "-encryptany", + "-env", + "-errfile", + "-errpfx", + "-noorderchk", + "-orderchkonly", + "-unref", + "--", + NULL + }; + enum bdbvrfy { + TCL_DBVRFY_BTCOMPARE, + TCL_DBVRFY_DUPCOMPARE, + TCL_DBVRFY_HASHCOMPARE, + TCL_DBVRFY_HASHPROC, + + TCL_DBVRFY_ENCRYPT, + TCL_DBVRFY_ENCRYPT_AES, + TCL_DBVRFY_ENCRYPT_ANY, + TCL_DBVRFY_ENV, + TCL_DBVRFY_ERRFILE, + TCL_DBVRFY_ERRPFX, + TCL_DBVRFY_NOORDERCHK, + TCL_DBVRFY_ORDERCHKONLY, + TCL_DBVRFY_UNREF, + TCL_DBVRFY_ENDARG + }; + DB_ENV *dbenv; + DB *dbp; + FILE *errf; + int (*bt_compare) __P((DB *, const DBT *, const DBT *)); + int (*dup_compare) __P((DB *, const DBT *, const DBT *)); + int (*h_compare) __P((DB *, const DBT *, const DBT *)); + u_int32_t (*h_hash)__P((DB *, const void *, u_int32_t)); + u_int32_t enc_flag, flags, set_flags; + int endarg, i, optindex, result, ret, subdblen; + char *arg, *db, *errpfx, *passwd, *subdb; + u_char *subdbtmp; + + dbenv = NULL; + dbp = NULL; + passwd = NULL; + result = TCL_OK; + db = errpfx = subdb = NULL; + errf = NULL; + bt_compare = NULL; + dup_compare = NULL; + h_compare = NULL; + h_hash = NULL; + flags = endarg = 0; + enc_flag = set_flags = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], bdbverify, + "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 bdbvrfy)optindex) { + case TCL_DBVRFY_BTCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-btcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * We don't need to crack it out now--we'll want + * to bundle it up to pass into Tcl_EvalObjv anyway. + * Tcl's object refcounting will--I hope--take care + * of the memory management here. + */ + ip->i_compare = objv[i++]; + Tcl_IncrRefCount(ip->i_compare); + _debug_check(); + bt_compare = tcl_bt_compare; + break; + case TCL_DBVRFY_DUPCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-dupcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * See TCL_DBVRFY_BTCOMPARE. + */ + ip->i_dupcompare = objv[i++]; + Tcl_IncrRefCount(ip->i_dupcompare); + _debug_check(); + dup_compare = tcl_dup_compare; + break; + case TCL_DBVRFY_HASHCOMPARE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-hashcompare compareproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * We don't need to crack it out now--we'll want + * to bundle it up to pass into Tcl_EvalObjv anyway. + * Tcl's object refcounting will--I hope--take care + * of the memory management here. + */ + ip->i_compare = objv[i++]; + Tcl_IncrRefCount(ip->i_compare); + _debug_check(); + h_compare = tcl_bt_compare; + break; + case TCL_DBVRFY_HASHPROC: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-hashproc hashproc"); + result = TCL_ERROR; + break; + } + + /* + * Store the object containing the procedure name. + * See TCL_DBVRFY_BTCOMPARE. + */ + ip->i_hashproc = objv[i++]; + Tcl_IncrRefCount(ip->i_hashproc); + _debug_check(); + h_hash = tcl_h_hash; + break; + case TCL_DBVRFY_ENCRYPT: + set_flags |= DB_ENCRYPT; + _debug_check(); + break; + case TCL_DBVRFY_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = DB_ENCRYPT_AES; + break; + case TCL_DBVRFY_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = 0; + break; + case TCL_DBVRFY_ENV: + arg = Tcl_GetStringFromObj(objv[i++], NULL); + dbenv = NAME_TO_ENV(arg); + if (dbenv == NULL) { + Tcl_SetResult(interp, + "db verify: illegal environment", + TCL_STATIC); + result = TCL_ERROR; + break; + } + break; + case TCL_DBVRFY_ERRFILE: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errfile file"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + /* + * If the user already set one, close it. + */ + if (errf != NULL && errf != stdout && errf != stderr) + (void)fclose(errf); + if (strcmp(arg, "/dev/stdout") == 0) + errf = stdout; + else if (strcmp(arg, "/dev/stderr") == 0) + errf = stderr; + else + errf = fopen(arg, "a"); + break; + case TCL_DBVRFY_ERRPFX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-errpfx prefix"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + /* + * If the user already set one, free it. + */ + if (errpfx != NULL) + __os_free(dbenv->env, errpfx); + if ((ret = __os_strdup(NULL, arg, &errpfx)) != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "__os_strdup"); + break; + } + break; + case TCL_DBVRFY_NOORDERCHK: + flags |= DB_NOORDERCHK; + break; + case TCL_DBVRFY_ORDERCHKONLY: + flags |= DB_ORDERCHKONLY; + break; + case TCL_DBVRFY_UNREF: + flags |= DB_UNREF; + break; + case TCL_DBVRFY_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; + /* + * The remaining arg is the db filename. + */ + /* + * Any args we have left, (better be 1 or 2 left) are + * file names. If there is 1, a db name, if 2 a db and subdb name. + */ + if (i != objc) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i != objc) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc(dbenv->env, + (size_t)subdblen + 1, &subdb)) != 0) { + Tcl_SetResult(interp, db_strerror(ret), + TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename"); + result = TCL_ERROR; + goto error; + } + + ret = db_create(&dbp, dbenv, 0); + if (ret) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_create"); + goto error; + } + + /* Hang our info pointer on the DB handle, so we can do callbacks. */ + dbp->api_internal = ip; + + if (errf != NULL) + dbp->set_errfile(dbp, errf); + if (errpfx != NULL) + dbp->set_errpfx(dbp, errpfx); + + if (passwd != NULL && + (ret = dbp->set_encrypt(dbp, passwd, enc_flag)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + goto error; + } + + if (set_flags != 0 && + (ret = dbp->set_flags(dbp, set_flags)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + goto error; + } + if (bt_compare != NULL && + (ret = dbp->set_bt_compare(dbp, bt_compare)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_bt_compare"); + goto error; + } + if (dup_compare != NULL && + (ret = dbp->set_dup_compare(dbp, dup_compare)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_dup_compare"); + goto error; + } + if (h_compare != NULL && + (ret = dbp->set_h_compare(dbp, h_compare)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_h_compare"); + goto error; + } + if (h_hash != NULL && + (ret = dbp->set_h_hash(dbp, h_hash)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_h_hash"); + goto error; + } + + /* + * The verify method is a destructor, NULL out the dbp. + */ + ret = dbp->verify(dbp, db, subdb, NULL, flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db verify"); + dbp = NULL; +error: + if (errf != NULL && errf != stdout && errf != stderr) + (void)fclose(errf); + if (errpfx != NULL) + __os_free(dbenv->env, errpfx); + if (dbp) + (void)dbp->close(dbp, 0); + return (result); +} +#endif + +/* + * bdb_Version -- + * Implements the version command. + */ +static int +bdb_Version(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *bdbver[] = { + "-string", NULL + }; + enum bdbver { + TCL_VERSTRING + }; + int i, optindex, maj, min, patch, result, string, verobjc; + char *arg, *v; + Tcl_Obj *res, *verobjv[3]; + + result = TCL_OK; + string = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], bdbver, + "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 bdbver)optindex) { + case TCL_VERSTRING: + string = 1; + break; + } + /* + * If, at any time, parsing the args we get an error, + * bail out and return. + */ + if (result != TCL_OK) + goto error; + } + if (result != TCL_OK) + goto error; + + v = db_version(&maj, &min, &patch); + if (string) + res = NewStringObj(v, strlen(v)); + else { + verobjc = 3; + verobjv[0] = Tcl_NewIntObj(maj); + verobjv[1] = Tcl_NewIntObj(min); + verobjv[2] = Tcl_NewIntObj(patch); + res = Tcl_NewListObj(verobjc, verobjv); + } + Tcl_SetObjResult(interp, res); +error: + return (result); +} + +#ifdef CONFIG_TEST +/* + * bdb_GetConfig -- + * Implements the getconfig command. + */ +#define ADD_CONFIG_NAME(name) \ + conf = NewStringObj(name, strlen(name)); \ + if (Tcl_ListObjAppendElement(interp, res, conf) != TCL_OK) \ + return (TCL_ERROR); + +static int +bdb_GetConfig(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + Tcl_Obj *res, *conf; + + /* + * No args. Error if we have some + */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return (TCL_ERROR); + } + res = Tcl_NewListObj(0, NULL); + conf = NULL; + + /* + * This command conditionally adds strings in based on + * how DB is configured so that the test suite can make + * decisions based on that. For now only implement the + * configuration pieces we need. + */ +#ifdef DEBUG + ADD_CONFIG_NAME("debug"); +#endif +#ifdef DEBUG_ROP + ADD_CONFIG_NAME("debug_rop"); +#endif +#ifdef DEBUG_WOP + ADD_CONFIG_NAME("debug_wop"); +#endif +#ifdef DIAGNOSTIC + ADD_CONFIG_NAME("diagnostic"); +#endif +#ifdef HAVE_PARTITION + ADD_CONFIG_NAME("partition"); +#endif +#ifdef HAVE_HASH + ADD_CONFIG_NAME("hash"); +#endif +#ifdef HAVE_QUEUE + ADD_CONFIG_NAME("queue"); +#endif +#ifdef HAVE_REPLICATION + ADD_CONFIG_NAME("rep"); +#endif +#ifdef HAVE_REPLICATION_THREADS + ADD_CONFIG_NAME("repmgr"); +#endif +#ifdef HAVE_RPC + ADD_CONFIG_NAME("rpc"); +#endif +#ifdef HAVE_VERIFY + ADD_CONFIG_NAME("verify"); +#endif + Tcl_SetObjResult(interp, res); + return (TCL_OK); +} + +/* + * bdb_Handles -- + * Implements the handles command. + */ +static int +bdb_Handles(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + DBTCL_INFO *p; + Tcl_Obj *res, *handle; + + /* + * No args. Error if we have some + */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return (TCL_ERROR); + } + res = Tcl_NewListObj(0, NULL); + + LIST_FOREACH(p, &__db_infohead, entries) { + handle = NewStringObj(p->i_name, strlen(p->i_name)); + if (Tcl_ListObjAppendElement(interp, res, handle) != TCL_OK) + return (TCL_ERROR); + } + Tcl_SetObjResult(interp, res); + return (TCL_OK); +} + +/* + * bdb_MsgType - + * Implements the msgtype command. + * Given a replication message return its message type name. + */ +static int +bdb_MsgType(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + __rep_control_args *rp; + Tcl_Obj *msgname; + u_int32_t len, msgtype, swaptype; + int freerp, ret; + + /* + * If the messages in rep.h change, this must change too! + * Add "no_type" for 0 so that we directly index. + */ + static const char *msgnames[] = { + "no_type", "alive", "alive_req", "all_req", + "bulk_log", "bulk_page", + "dupmaster", "file", "file_fail", "file_req", "lease_grant", + "log", "log_more", "log_req", "master_req", "newclient", + "newfile", "newmaster", "newsite", "page", + "page_fail", "page_more", "page_req", + "rerequest", "startsync", "update", "update_req", + "verify", "verify_fail", "verify_req", + "vote1", "vote2", NULL + }; + + /* + * 1 arg, the message. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "msgtype msg"); + return (TCL_ERROR); + } + + ret = _CopyObjBytes(interp, objv[2], &rp, &len, &freerp); + if (ret != TCL_OK) { + Tcl_SetResult(interp, + "msgtype: bad control message", TCL_STATIC); + return (TCL_ERROR); + } + swaptype = msgtype = rp->rectype; + /* + * We have no DB_ENV or ENV here. The message type may be + * swapped. Get both and use the one that is in the message range. + */ + M_32_SWAP(swaptype); + if (msgtype > REP_MAX_MSG && swaptype <= REP_MAX_MSG) + msgtype = swaptype; + msgname = NewStringObj(msgnames[msgtype], strlen(msgnames[msgtype])); + Tcl_SetObjResult(interp, msgname); + if (rp != NULL && freerp) + __os_free(NULL, rp); + return (TCL_OK); +} + +/* + * bdb_DbUpgrade -- + * Implements the DB->upgrade command. + */ +static int +bdb_DbUpgrade(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *bdbupg[] = { + "-dupsort", "-env", "--", NULL + }; + enum bdbupg { + TCL_DBUPG_DUPSORT, + TCL_DBUPG_ENV, + TCL_DBUPG_ENDARG + }; + DB_ENV *dbenv; + DB *dbp; + u_int32_t flags; + int endarg, i, optindex, result, ret; + char *arg, *db; + + dbenv = NULL; + dbp = NULL; + result = TCL_OK; + db = NULL; + flags = endarg = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename"); + return (TCL_ERROR); + } + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], bdbupg, + "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 bdbupg)optindex) { + case TCL_DBUPG_DUPSORT: + flags |= DB_DUPSORT; + break; + case TCL_DBUPG_ENV: + arg = Tcl_GetStringFromObj(objv[i++], NULL); + dbenv = NAME_TO_ENV(arg); + if (dbenv == NULL) { + Tcl_SetResult(interp, + "db upgrade: illegal environment", + TCL_STATIC); + return (TCL_ERROR); + } + break; + case TCL_DBUPG_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; + /* + * The remaining arg is the db filename. + */ + if (i == (objc - 1)) + db = Tcl_GetStringFromObj(objv[i++], NULL); + else { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename"); + result = TCL_ERROR; + goto error; + } + ret = db_create(&dbp, dbenv, 0); + if (ret) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_create"); + goto error; + } + + /* + * XXX + * Remove restriction if error handling not tied to env. + * + * The DB->set_err* functions overwrite the environment. So, if + * we are using an env, don't overwrite it; if not using an env, + * then configure error handling. + */ + if (dbenv == NULL) { + dbp->set_errpfx(dbp, "DbUpgrade"); + dbp->set_errcall(dbp, _ErrorFunc); + } + ret = dbp->upgrade(dbp, db, flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db upgrade"); +error: + if (dbp) + (void)dbp->close(dbp, 0); + return (result); +} + +/* + * tcl_bt_compare and tcl_dup_compare -- + * These two are basically identical internally, so may as well + * share code. The only differences are the name used in error + * reporting and the Tcl_Obj representing their respective procs. + */ +static int +tcl_bt_compare(dbp, dbta, dbtb) + DB *dbp; + const DBT *dbta, *dbtb; +{ + return (tcl_compare_callback(dbp, dbta, dbtb, + ((DBTCL_INFO *)dbp->api_internal)->i_compare, "bt_compare")); +} + +static int +tcl_dup_compare(dbp, dbta, dbtb) + DB *dbp; + const DBT *dbta, *dbtb; +{ + return (tcl_compare_callback(dbp, dbta, dbtb, + ((DBTCL_INFO *)dbp->api_internal)->i_dupcompare, "dup_compare")); +} + +/* + * tcl_compare_callback -- + * Tcl callback for set_bt_compare and set_dup_compare. What this + * function does is stuff the data fields of the two DBTs into Tcl ByteArray + * objects, then call the procedure stored in ip->i_compare on the two + * objects. Then we return that procedure's result as the comparison. + */ +static int +tcl_compare_callback(dbp, dbta, dbtb, procobj, errname) + DB *dbp; + const DBT *dbta, *dbtb; + Tcl_Obj *procobj; + char *errname; +{ + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *a, *b, *resobj, *objv[3]; + int result, cmp; + + ip = (DBTCL_INFO *)dbp->api_internal; + interp = ip->i_interp; + objv[0] = procobj; + + /* + * Create two ByteArray objects, with the two data we've been passed. + * This will involve a copy, which is unpleasantly slow, but there's + * little we can do to avoid this (I think). + */ + a = Tcl_NewByteArrayObj(dbta->data, (int)dbta->size); + Tcl_IncrRefCount(a); + b = Tcl_NewByteArrayObj(dbtb->data, (int)dbtb->size); + Tcl_IncrRefCount(b); + + objv[1] = a; + objv[2] = b; + + result = Tcl_EvalObjv(interp, 3, objv, 0); + if (result != TCL_OK) { + /* + * XXX + * If this or the next Tcl call fails, we're doomed. + * There's no way to return an error from comparison functions, + * no way to determine what the correct sort order is, and + * so no way to avoid corrupting the database if we proceed. + * We could play some games stashing return values on the + * DB handle, but it's not worth the trouble--no one with + * any sense is going to be using this other than for testing, + * and failure typically means that the bt_compare proc + * had a syntax error in it or something similarly dumb. + * + * So, drop core. If we're not running with diagnostic + * mode, panic--and always return a negative number. :-) + */ +panic: __db_errx(dbp->env, "Tcl %s callback failed", errname); + return (__env_panic(dbp->env, DB_RUNRECOVERY)); + } + + resobj = Tcl_GetObjResult(interp); + result = Tcl_GetIntFromObj(interp, resobj, &cmp); + if (result != TCL_OK) + goto panic; + + Tcl_DecrRefCount(a); + Tcl_DecrRefCount(b); + return (cmp); +} + +/* + * tcl_h_hash -- + * Tcl callback for the hashing function. See tcl_compare_callback-- + * this works much the same way, only we're given a buffer and a length + * instead of two DBTs. + */ +static u_int32_t +tcl_h_hash(dbp, buf, len) + DB *dbp; + const void *buf; + u_int32_t len; +{ + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *objv[2]; + int result, hval; + + ip = (DBTCL_INFO *)dbp->api_internal; + interp = ip->i_interp; + objv[0] = ip->i_hashproc; + + /* + * Create a ByteArray for the buffer. + */ + objv[1] = Tcl_NewByteArrayObj((void *)buf, (int)len); + Tcl_IncrRefCount(objv[1]); + result = Tcl_EvalObjv(interp, 2, objv, 0); + if (result != TCL_OK) + goto panic; + + result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &hval); + if (result != TCL_OK) + goto panic; + + Tcl_DecrRefCount(objv[1]); + return ((u_int32_t)hval); + +panic: __db_errx(dbp->env, "Tcl h_hash callback failed"); + + (void)__env_panic(dbp->env, DB_RUNRECOVERY); + return (0); +} + +static int +tcl_isalive(dbenv, pid, tid, flags) + DB_ENV *dbenv; + pid_t pid; + db_threadid_t tid; + u_int32_t flags; +{ + ENV *env; + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *objv[2]; + pid_t mypid; + db_threadid_t mytid; + int answer, result; + + __os_id(dbenv, &mypid, &mytid); + if (mypid == pid && (LF_ISSET(DB_MUTEX_PROCESS_ONLY) || + mytid == tid)) + return (1); + /* + * We only support the PROCESS_ONLY case for now, because that seems + * easiest, and that's all we need for our tests for the moment. + */ + if (!LF_ISSET(DB_MUTEX_PROCESS_ONLY)) + return (1); + + ip = (DBTCL_INFO *)dbenv->app_private; + interp = ip->i_interp; + objv[0] = ip->i_isalive; + + objv[1] = Tcl_NewLongObj((long)pid); + Tcl_IncrRefCount(objv[1]); + + result = Tcl_EvalObjv(interp, 2, objv, 0); + if (result != TCL_OK) + goto panic; + Tcl_DecrRefCount(objv[1]); + result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &answer); + if (result != TCL_OK) + goto panic; + + return (answer); + +panic: + env = dbenv->env; + __db_errx(env, "Tcl isalive callback failed: %s", + Tcl_GetStringResult(interp)); + + (void)__env_panic(env, DB_RUNRECOVERY); + return (0); +} + +/* + * tcl_part_callback -- + */ +static u_int32_t +tcl_part_callback(dbp, data) + DB *dbp; + DBT *data; +{ + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *objv[2]; + int result, hval; + + ip = (DBTCL_INFO *)dbp->api_internal; + interp = ip->i_interp; + objv[0] = ip->i_part_callback; + + objv[1] = Tcl_NewByteArrayObj(data->data, (int)data->size); + Tcl_IncrRefCount(objv[1]); + + result = Tcl_EvalObjv(interp, 2, objv, 0); + if (result != TCL_OK) + goto panic; + + result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &hval); + if (result != TCL_OK) + goto panic; + + Tcl_DecrRefCount(objv[1]); + return ((u_int32_t)hval); + +panic: __db_errx(dbp->env, "Tcl part_callback callback failed"); + + (void)__env_panic(dbp->env, DB_RUNRECOVERY); + return (0); +} + +/* + * tcl_rep_send -- + * Replication send callback. + * + * PUBLIC: int tcl_rep_send __P((DB_ENV *, + * PUBLIC: const DBT *, const DBT *, const DB_LSN *, int, u_int32_t)); + */ +int +tcl_rep_send(dbenv, control, rec, lsnp, eid, flags) + DB_ENV *dbenv; + const DBT *control, *rec; + const DB_LSN *lsnp; + int eid; + u_int32_t flags; +{ +#define TCLDB_SENDITEMS 7 +#define TCLDB_MAXREPFLAGS 32 + DBTCL_INFO *ip; + Tcl_Interp *interp; + Tcl_Obj *control_o, *eid_o, *flags_o, *lsn_o, *origobj, *rec_o; + Tcl_Obj *lsnobj[2], *myobjv[TCLDB_MAXREPFLAGS], *objv[TCLDB_SENDITEMS]; + Tcl_Obj *resobj; + int i, myobjc, result, ret; + + ip = (DBTCL_INFO *)dbenv->app_private; + interp = ip->i_interp; + objv[0] = ip->i_rep_send; + + control_o = Tcl_NewByteArrayObj(control->data, (int)control->size); + Tcl_IncrRefCount(control_o); + + rec_o = Tcl_NewByteArrayObj(rec->data, (int)rec->size); + Tcl_IncrRefCount(rec_o); + + eid_o = Tcl_NewIntObj(eid); + Tcl_IncrRefCount(eid_o); + + myobjv[myobjc = 0] = NULL; + if (flags == 0) + myobjv[myobjc++] = NewStringObj("none", strlen("none")); + if (LF_ISSET(DB_REP_ANYWHERE)) + myobjv[myobjc++] = NewStringObj("any", strlen("any")); + if (LF_ISSET(DB_REP_NOBUFFER)) + myobjv[myobjc++] = NewStringObj("nobuffer", strlen("nobuffer")); + if (LF_ISSET(DB_REP_PERMANENT)) + myobjv[myobjc++] = NewStringObj("perm", strlen("perm")); + if (LF_ISSET(DB_REP_REREQUEST)) + myobjv[myobjc++] = + NewStringObj("rerequest", strlen("rerequest")); + /* + * If we're given an unrecognized flag send "unknown". + */ + if (myobjc == 0) + myobjv[myobjc++] = NewStringObj("unknown", strlen("unknown")); + for (i = 0; i < myobjc; i++) + Tcl_IncrRefCount(myobjv[i]); + flags_o = Tcl_NewListObj(myobjc, myobjv); + Tcl_IncrRefCount(flags_o); + + lsnobj[0] = Tcl_NewLongObj((long)lsnp->file); + Tcl_IncrRefCount(lsnobj[0]); + lsnobj[1] = Tcl_NewLongObj((long)lsnp->offset); + Tcl_IncrRefCount(lsnobj[1]); + lsn_o = Tcl_NewListObj(2, lsnobj); + Tcl_IncrRefCount(lsn_o); + + objv[1] = control_o; + objv[2] = rec_o; + objv[3] = ip->i_rep_eid; /* From ID */ + objv[4] = eid_o; /* To ID */ + objv[5] = flags_o; /* Flags */ + objv[6] = lsn_o; /* LSN */ + + /* + * 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_SENDITEMS, 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. + */ +err: __db_errx(dbenv->env, + "Tcl rep_send failure: %s", Tcl_GetStringResult(interp)); + return (EINVAL); + } + + resobj = Tcl_GetObjResult(interp); + result = Tcl_GetIntFromObj(interp, resobj, &ret); + if (result != TCL_OK) + goto err; + + Tcl_SetObjResult(interp, origobj); + Tcl_DecrRefCount(origobj); + Tcl_DecrRefCount(control_o); + Tcl_DecrRefCount(rec_o); + Tcl_DecrRefCount(eid_o); + for (i = 0; i < myobjc; i++) + Tcl_DecrRefCount(myobjv[i]); + Tcl_DecrRefCount(flags_o); + Tcl_DecrRefCount(lsnobj[0]); + Tcl_DecrRefCount(lsnobj[1]); + Tcl_DecrRefCount(lsn_o); + + return (ret); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_db_malloc, tcl_db_realloc, tcl_db_free -- + * Tcl-local malloc, realloc, and free functions to use for user data + * to exercise umalloc/urealloc/ufree. Allocate the memory as a Tcl object + * so we're sure to exacerbate and catch any shared-library issues. + */ +static void * +tcl_db_malloc(size) + size_t size; +{ + Tcl_Obj *obj; + void *buf; + + obj = Tcl_NewObj(); + if (obj == NULL) + return (NULL); + Tcl_IncrRefCount(obj); + + Tcl_SetObjLength(obj, (int)(size + sizeof(Tcl_Obj *))); + buf = Tcl_GetString(obj); + memcpy(buf, &obj, sizeof(&obj)); + + buf = (Tcl_Obj **)buf + 1; + return (buf); +} + +static void * +tcl_db_realloc(ptr, size) + void *ptr; + size_t size; +{ + Tcl_Obj *obj; + + if (ptr == NULL) + return (tcl_db_malloc(size)); + + obj = *(Tcl_Obj **)((Tcl_Obj **)ptr - 1); + Tcl_SetObjLength(obj, (int)(size + sizeof(Tcl_Obj *))); + + ptr = Tcl_GetString(obj); + memcpy(ptr, &obj, sizeof(&obj)); + + ptr = (Tcl_Obj **)ptr + 1; + return (ptr); +} + +static void +tcl_db_free(ptr) + void *ptr; +{ + Tcl_Obj *obj; + + obj = *(Tcl_Obj **)((Tcl_Obj **)ptr - 1); + Tcl_DecrRefCount(obj); +} + +static int +tcl_set_partition_keys(interp, dbp, obj, keyp) + Tcl_Interp *interp; + DB *dbp; + Tcl_Obj *obj; + DBT **keyp; +{ + DBT *keys, *kp; + Tcl_Obj **obj_list; + u_int32_t i, count; + int ret; + + *keyp = NULL; + if ((ret = Tcl_ListObjGetElements(interp, + obj, (int *)&count, &obj_list)) != TCL_OK) + return (EINVAL); + + if ((ret = __os_calloc(NULL, count, sizeof(DBT), &keys)) != 0) + return (ret); + + *keyp = keys; + + kp = keys; + for (i = 0; i < count; i++, kp++) + kp->data = Tcl_GetStringFromObj(obj_list[i], (int*)&kp->size); + + if ((ret = dbp->set_partition(dbp, + (u_int32_t)count + 1, keys, NULL)) != 0) + return (ret); + + return (0); +} + +static int +tcl_set_partition_dirs(interp, dbp, obj) + Tcl_Interp *interp; + DB *dbp; + Tcl_Obj *obj; +{ + char **dp, **dirs; + Tcl_Obj **obj_list; + u_int32_t i, count; + int ret; + + if ((ret = Tcl_ListObjGetElements(interp, + obj, (int*)&count, &obj_list)) != TCL_OK) + return (EINVAL); + + if ((ret = __os_calloc(NULL, count + 1, sizeof(char *), &dirs)) != 0) + return (ret); + + dp = dirs; + for (i = 0; i < count; i++, dp++) + *dp = Tcl_GetStringFromObj(obj_list[i], NULL); + + if ((ret = dbp->set_partition_dirs(dbp, (const char **)dirs)) != 0) + return (ret); + + __os_free(NULL, dirs); + + return (0); +} +#endif diff --git a/tcl/tcl_dbcursor.c b/tcl/tcl_dbcursor.c new file mode 100644 index 0000000..9b943ba --- /dev/null +++ b/tcl/tcl_dbcursor.c @@ -0,0 +1,1056 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_DbcCompare __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", + "cmp", + "del", + "dup", + "get", + "put", + NULL + }; + enum dbccmds { +#ifdef CONFIG_TEST + DBCPGET, +#endif + DBCCLOSE, + DBCCOMPARE, + 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 DBCCOMPARE: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 3, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + result = tcl_DbcCompare(interp, objc, objv, dbc); + 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", + "-overwritedup", + "-partial", + NULL + }; + enum dbcutopts { +#ifdef CONFIG_TEST + DBCPUT_NODUPDATA, +#endif + DBCPUT_AFTER, + DBCPUT_BEFORE, + DBCPUT_CURRENT, + DBCPUT_KEYFIRST, + DBCPUT_KEYLAST, + DBCPUT_OVERWRITE_DUP, + 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_OVERWRITE_DUP: + FLAG_CHECK(flag); + flag = DB_OVERWRITE_DUP; + 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 | DB_READ_COMMITTED) + + 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_DbcCompare -- + */ +static int +tcl_DbcCompare(interp, objc, objv, dbc) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBC *dbc; /* Cursor pointer */ +{ + DBC *odbc; + DBTCL_INFO *dbcip, *dbip; + Tcl_Obj *res; + int cmp_res, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + res = NULL; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "?-args?"); + return (TCL_ERROR); + } + + 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; + } + } + /* + * When we get here, we better have: + * 2 args one DBC and an int address for the result + */ + arg = Tcl_GetStringFromObj(objv[2], NULL); + odbc = NAME_TO_DBC(arg); + if (odbc == NULL) { + snprintf(msg, MSG_SIZE, + "Cmp: Invalid cursor: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + goto out; + } + + ret = dbc->cmp(dbc, odbc, &cmp_res, 0); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "dbc cmp"); + return (result); + } + res = Tcl_NewIntObj(cmp_res); + Tcl_SetObjResult(interp, res); +out: + 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); + +} diff --git a/tcl/tcl_env.c b/tcl/tcl_env.c new file mode 100644 index 0000000..15d7b70 --- /dev/null +++ b/tcl/tcl_env.c @@ -0,0 +1,2670 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#include "db_config.h" + +#include "db_int.h" +#ifdef HAVE_SYSTEM_INCLUDE_FILES +#include <tcl.h> +#endif +#include "dbinc/lock.h" +#include "dbinc/txn.h" +#include "dbinc/tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +static void _EnvInfoDelete __P((Tcl_Interp *, DBTCL_INFO *)); +static int env_DbRemove __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_DbRename __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_GetFlags __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_GetOpenFlag + __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_GetLockDetect + __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_GetTimeout __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); +static int env_GetVerbose __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); + +/* + * PUBLIC: int env_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); + * + * env_Cmd -- + * Implements the "env" command. + */ +int +env_Cmd(clientData, interp, objc, objv) + ClientData clientData; /* Env handle */ + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static const char *envcmds[] = { +#ifdef CONFIG_TEST + "attributes", + "errfile", + "errpfx", + "event", + "failchk", + "id_reset", + "lock_detect", + "lock_id", + "lock_id_free", + "lock_id_set", + "lock_get", + "lock_stat", + "lock_timeout", + "lock_vec", + "log_archive", + "log_compare", + "log_config", + "log_cursor", + "log_file", + "log_flush", + "log_get", + "log_get_config", + "log_put", + "log_stat", + "lsn_reset", + "mpool", + "mpool_stat", + "mpool_sync", + "mpool_trickle", + "mutex", + "mutex_free", + "mutex_get_align", + "mutex_get_incr", + "mutex_get_max", + "mutex_get_tas_spins", + "mutex_lock", + "mutex_set_tas_spins", + "mutex_stat", + "mutex_unlock", + "rep_config", + "rep_elect", + "rep_flush", + "rep_get_clockskew", + "rep_get_config", + "rep_get_limit", + "rep_get_nsites", + "rep_get_request", + "rep_get_timeout", + "rep_lease", + "rep_limit", + "rep_process_message", + "rep_request", + "rep_start", + "rep_stat", + "rep_sync", + "rep_transport", + "repmgr", + "repmgr_site_list", + "repmgr_stat", + "rpcid", + "set_flags", + "test", + "txn_id_set", + "txn_recover", + "txn_stat", + "txn_timeout", + "verbose", +#endif + "cdsgroup", + "close", + "dbremove", + "dbrename", + "get_cachesize", + "get_cache_max", + "get_data_dirs", + "get_encrypt_flags", + "get_errpfx", + "get_flags", + "get_home", + "get_lg_bsize", + "get_lg_dir", + "get_lg_filemode", + "get_lg_max", + "get_lg_regionmax", + "get_lk_detect", + "get_lk_max_lockers", + "get_lk_max_locks", + "get_lk_max_objects", + "get_mp_max_openfd", + "get_mp_max_write", + "get_mp_mmapsize", + "get_open_flags", + "get_shm_key", + "get_tas_spins", + "get_timeout", + "get_tmp_dir", + "get_tx_max", + "get_tx_timestamp", + "get_verbose", + "resize_cache", + "set_data_dir", + "txn", + "txn_checkpoint", + NULL + }; + enum envcmds { +#ifdef CONFIG_TEST + ENVATTR, + ENVERRFILE, + ENVERRPFX, + ENVEVENT, + ENVFAILCHK, + ENVIDRESET, + ENVLKDETECT, + ENVLKID, + ENVLKFREEID, + ENVLKSETID, + ENVLKGET, + ENVLKSTAT, + ENVLKTIMEOUT, + ENVLKVEC, + ENVLOGARCH, + ENVLOGCMP, + ENVLOGCONFIG, + ENVLOGCURSOR, + ENVLOGFILE, + ENVLOGFLUSH, + ENVLOGGET, + ENVLOGGETCONFIG, + ENVLOGPUT, + ENVLOGSTAT, + ENVLSNRESET, + ENVMP, + ENVMPSTAT, + ENVMPSYNC, + ENVTRICKLE, + ENVMUTEX, + ENVMUTFREE, + ENVMUTGETALIGN, + ENVMUTGETINCR, + ENVMUTGETMAX, + ENVMUTGETTASSPINS, + ENVMUTLOCK, + ENVMUTSETTASSPINS, + ENVMUTSTAT, + ENVMUTUNLOCK, + ENVREPCONFIG, + ENVREPELECT, + ENVREPFLUSH, + ENVREPGETCLOCKSKEW, + ENVREPGETCONFIG, + ENVREPGETLIMIT, + ENVREPGETNSITES, + ENVREPGETREQUEST, + ENVREPGETTIMEOUT, + ENVREPLEASE, + ENVREPLIMIT, + ENVREPPROCMESS, + ENVREPREQUEST, + ENVREPSTART, + ENVREPSTAT, + ENVREPSYNC, + ENVREPTRANSPORT, + ENVREPMGR, + ENVREPMGRSITELIST, + ENVREPMGRSTAT, + ENVRPCID, + ENVSETFLAGS, + ENVTEST, + ENVTXNSETID, + ENVTXNRECOVER, + ENVTXNSTAT, + ENVTXNTIMEOUT, + ENVVERB, +#endif + ENVCDSGROUP, + ENVCLOSE, + ENVDBREMOVE, + ENVDBRENAME, + ENVGETCACHESIZE, + ENVGETCACHEMAX, + ENVGETDATADIRS, + ENVGETENCRYPTFLAGS, + ENVGETERRPFX, + ENVGETFLAGS, + ENVGETHOME, + ENVGETLGBSIZE, + ENVGETLGDIR, + ENVGETLGFILEMODE, + ENVGETLGMAX, + ENVGETLGREGIONMAX, + ENVGETLKDETECT, + ENVGETLKMAXLOCKERS, + ENVGETLKMAXLOCKS, + ENVGETLKMAXOBJECTS, + ENVGETMPMAXOPENFD, + ENVGETMPMAXWRITE, + ENVGETMPMMAPSIZE, + ENVGETOPENFLAG, + ENVGETSHMKEY, + ENVGETTASSPINS, + ENVGETTIMEOUT, + ENVGETTMPDIR, + ENVGETTXMAX, + ENVGETTXTIMESTAMP, + ENVGETVERBOSE, + ENVRESIZECACHE, + ENVSETDATADIR, + ENVTXN, + ENVTXNCKP + }; + DBTCL_INFO *envip; + DB_ENV *dbenv; + Tcl_Obj **listobjv, *myobjv[3], *res; + db_timeout_t timeout; + size_t size; + time_t timeval; + u_int32_t bytes, gbytes, value; + long shm_key; + int cmdindex, i, intvalue, listobjc, ncache, result, ret; + const char *strval, **dirs; + char *strarg, newname[MSG_SIZE]; +#ifdef CONFIG_TEST + DBTCL_INFO *logcip; + DB_LOGC *logc; + u_int32_t lockid; + long newval, otherval; +#endif + + Tcl_ResetResult(interp); + dbenv = (DB_ENV *)clientData; + envip = _PtrToInfo((void *)dbenv); + result = TCL_OK; + memset(newname, 0, MSG_SIZE); + + if (objc <= 1) { + Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs"); + return (TCL_ERROR); + } + if (dbenv == NULL) { + Tcl_SetResult(interp, "NULL env pointer", TCL_STATIC); + return (TCL_ERROR); + } + if (envip == NULL) { + Tcl_SetResult(interp, "NULL env 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], envcmds, "command", + TCL_EXACT, &cmdindex) != TCL_OK) + return (IS_HELP(objv[1])); + res = NULL; + switch ((enum envcmds)cmdindex) { +#ifdef CONFIG_TEST + case ENVEVENT: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_EventNotify(interp, dbenv, objv[2], envip); + break; + case ENVFAILCHK: + /* + * 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->failchk(dbenv, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "failchk"); + break; + case ENVIDRESET: + result = tcl_EnvIdReset(interp, objc, objv, dbenv); + break; + case ENVLSNRESET: + result = tcl_EnvLsnReset(interp, objc, objv, dbenv); + break; + case ENVLKDETECT: + result = tcl_LockDetect(interp, objc, objv, dbenv); + break; + case ENVLKSTAT: + result = tcl_LockStat(interp, objc, objv, dbenv); + break; + case ENVLKTIMEOUT: + result = tcl_LockTimeout(interp, objc, objv, dbenv); + break; + case ENVLKID: + /* + * 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_id(dbenv, &lockid); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "lock_id"); + if (result == TCL_OK) + res = Tcl_NewWideIntObj((Tcl_WideInt)lockid); + break; + case ENVLKFREEID: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, NULL); + return (TCL_ERROR); + } + result = Tcl_GetLongFromObj(interp, objv[2], &newval); + if (result != TCL_OK) + return (result); + ret = dbenv->lock_id_free(dbenv, (u_int32_t)newval); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "lock id_free"); + break; + case ENVLKSETID: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 4, objv, "current max"); + return (TCL_ERROR); + } + result = Tcl_GetLongFromObj(interp, objv[2], &newval); + if (result != TCL_OK) + return (result); + result = Tcl_GetLongFromObj(interp, objv[3], &otherval); + if (result != TCL_OK) + return (result); + ret = __lock_id_set(dbenv->env, + (u_int32_t)newval, (u_int32_t)otherval); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "lock id_free"); + break; + case ENVLKGET: + result = tcl_LockGet(interp, objc, objv, dbenv); + break; + case ENVLKVEC: + result = tcl_LockVec(interp, objc, objv, dbenv); + break; + case ENVLOGARCH: + result = tcl_LogArchive(interp, objc, objv, dbenv); + break; + case ENVLOGCMP: + result = tcl_LogCompare(interp, objc, objv); + break; + case ENVLOGCONFIG: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_LogConfig(interp, dbenv, objv[2]); + break; + case ENVLOGCURSOR: + snprintf(newname, sizeof(newname), + "%s.logc%d", envip->i_name, envip->i_envlogcid); + logcip = _NewInfo(interp, NULL, newname, I_LOGC); + if (logcip != NULL) { + ret = dbenv->log_cursor(dbenv, &logc, 0); + if (ret == 0) { + result = TCL_OK; + envip->i_envlogcid++; + /* + * We do NOT want to set i_parent to + * envip here because log cursors are + * not "tied" to the env. That is, they + * are NOT closed if the env is closed. + */ + (void)Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)logc_Cmd, + (ClientData)logc, NULL); + res = NewStringObj(newname, strlen(newname)); + _SetInfoData(logcip, logc); + } else { + _DeleteInfo(logcip); + result = _ErrorSetup(interp, ret, "log cursor"); + } + } else { + Tcl_SetResult(interp, + "Could not set up info", TCL_STATIC); + result = TCL_ERROR; + } + break; + case ENVLOGFILE: + result = tcl_LogFile(interp, objc, objv, dbenv); + break; + case ENVLOGFLUSH: + result = tcl_LogFlush(interp, objc, objv, dbenv); + break; + case ENVLOGGET: + result = tcl_LogGet(interp, objc, objv, dbenv); + break; + case ENVLOGGETCONFIG: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_LogGetConfig(interp, dbenv, objv[2]); + break; + case ENVLOGPUT: + result = tcl_LogPut(interp, objc, objv, dbenv); + break; + case ENVLOGSTAT: + result = tcl_LogStat(interp, objc, objv, dbenv); + break; + case ENVMPSTAT: + result = tcl_MpStat(interp, objc, objv, dbenv); + break; + case ENVMPSYNC: + result = tcl_MpSync(interp, objc, objv, dbenv); + break; + case ENVTRICKLE: + result = tcl_MpTrickle(interp, objc, objv, dbenv); + break; + case ENVMP: + result = tcl_Mp(interp, objc, objv, dbenv, envip); + break; + case ENVMUTEX: + result = tcl_Mutex(interp, objc, objv, dbenv); + break; + case ENVMUTFREE: + result = tcl_MutFree(interp, objc, objv, dbenv); + break; + case ENVMUTGETALIGN: + result = tcl_MutGet(interp, dbenv, DBTCL_MUT_ALIGN); + break; + case ENVMUTGETINCR: + result = tcl_MutGet(interp, dbenv, DBTCL_MUT_INCR); + break; + case ENVMUTGETMAX: + result = tcl_MutGet(interp, dbenv, DBTCL_MUT_MAX); + break; + case ENVMUTGETTASSPINS: + result = tcl_MutGet(interp, dbenv, DBTCL_MUT_TAS); + break; + case ENVMUTLOCK: + result = tcl_MutLock(interp, objc, objv, dbenv); + break; + case ENVMUTSETTASSPINS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_MutSet(interp, objv[2], dbenv, DBTCL_MUT_TAS); + break; + case ENVMUTSTAT: + result = tcl_MutStat(interp, objc, objv, dbenv); + break; + case ENVMUTUNLOCK: + result = tcl_MutUnlock(interp, objc, objv, dbenv); + break; + case ENVREPCONFIG: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_RepConfig(interp, dbenv, objv[2]); + break; + case ENVREPELECT: + result = tcl_RepElect(interp, objc, objv, dbenv); + break; + case ENVREPFLUSH: + result = tcl_RepFlush(interp, objc, objv, dbenv); + break; + case ENVREPGETCLOCKSKEW: + result = tcl_RepGetTwo(interp, dbenv, DBTCL_GETCLOCK); + break; + case ENVREPGETCONFIG: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_RepGetConfig(interp, dbenv, objv[2]); + break; + case ENVREPGETLIMIT: + result = tcl_RepGetTwo(interp, dbenv, DBTCL_GETLIMIT); + break; + case ENVREPGETNSITES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->rep_get_nsites(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_get_nsites")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVREPGETREQUEST: + result = tcl_RepGetTwo(interp, dbenv, DBTCL_GETREQ); + break; + case ENVREPGETTIMEOUT: + /* + * Two args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_RepGetTimeout(interp, dbenv, objv[2]); + break; + case ENVREPLEASE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = Tcl_ListObjGetElements(interp, objv[2], + &listobjc, &listobjv); + if (result == TCL_OK) + result = tcl_RepLease(interp, + listobjc, listobjv, dbenv); + break; + case ENVREPLIMIT: + result = tcl_RepLimit(interp, objc, objv, dbenv); + break; + case ENVREPPROCMESS: + result = tcl_RepProcessMessage(interp, objc, objv, dbenv); + break; + case ENVREPREQUEST: + result = tcl_RepRequest(interp, objc, objv, dbenv); + break; + case ENVREPSTART: + result = tcl_RepStart(interp, objc, objv, dbenv); + break; + case ENVREPSTAT: + result = tcl_RepStat(interp, objc, objv, dbenv); + break; + case ENVREPSYNC: + result = tcl_RepSync(interp, objc, objv, dbenv); + break; + case ENVREPTRANSPORT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = Tcl_ListObjGetElements(interp, objv[2], + &listobjc, &listobjv); + if (result == TCL_OK) + result = tcl_RepTransport(interp, + listobjc, listobjv, dbenv, envip); + break; + case ENVREPMGR: + result = tcl_RepMgr(interp, objc, objv, dbenv); + break; + case ENVREPMGRSITELIST: + result = tcl_RepMgrSiteList(interp, objc, objv, dbenv); + break; + case ENVREPMGRSTAT: + result = tcl_RepMgrStat(interp, objc, objv, dbenv); + break; + case ENVRPCID: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + /* + * !!! Retrieve the client ID from the dbp handle directly. + * This is for testing purposes only. It is BDB-private data. + */ + res = Tcl_NewLongObj((long)dbenv->cl_id); + break; + case ENVTXNSETID: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 4, objv, "current max"); + return (TCL_ERROR); + } + result = Tcl_GetLongFromObj(interp, objv[2], &newval); + if (result != TCL_OK) + return (result); + result = Tcl_GetLongFromObj(interp, objv[3], &otherval); + if (result != TCL_OK) + return (result); + ret = __txn_id_set(dbenv->env, + (u_int32_t)newval, (u_int32_t)otherval); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "txn setid"); + break; + case ENVTXNRECOVER: + result = tcl_TxnRecover(interp, objc, objv, dbenv, envip); + break; + case ENVTXNSTAT: + result = tcl_TxnStat(interp, objc, objv, dbenv); + break; + case ENVTXNTIMEOUT: + result = tcl_TxnTimeout(interp, objc, objv, dbenv); + break; + case ENVATTR: + result = tcl_EnvAttr(interp, objc, objv, dbenv); + break; + case ENVERRFILE: + /* + * One args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "errfile"); + return (TCL_ERROR); + } + strarg = Tcl_GetStringFromObj(objv[2], NULL); + tcl_EnvSetErrfile(interp, dbenv, envip, strarg); + result = TCL_OK; + break; + case ENVERRPFX: + /* + * One args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "pfx"); + return (TCL_ERROR); + } + strarg = Tcl_GetStringFromObj(objv[2], NULL); + result = tcl_EnvSetErrpfx(interp, dbenv, envip, strarg); + break; + case ENVSETFLAGS: + /* + * Two args for this. Error if different. + */ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "which on|off"); + return (TCL_ERROR); + } + result = tcl_EnvSetFlags(interp, dbenv, objv[2], objv[3]); + break; + case ENVTEST: + result = tcl_EnvTest(interp, objc, objv, dbenv); + break; + case ENVVERB: + /* + * Two args for this. Error if different. + */ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + result = tcl_EnvVerbose(interp, dbenv, objv[2], objv[3]); + break; +#endif + case ENVCDSGROUP: + result = tcl_CDSGroup(interp, objc, objv, dbenv, envip); + break; + case ENVCLOSE: + /* + * No args for this. Error if there are some. + */ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + /* + * Any transactions will be aborted, and an mpools + * closed automatically. We must delete any txn + * and mp widgets we have here too for this env. + * NOTE: envip is freed when we come back from + * this function. Set it to NULL to make sure no + * one tries to use it later. + */ + _debug_check(); + ret = dbenv->close(dbenv, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env close"); + _EnvInfoDelete(interp, envip); + envip = NULL; + break; + case ENVDBREMOVE: + result = env_DbRemove(interp, objc, objv, dbenv); + break; + case ENVDBRENAME: + result = env_DbRename(interp, objc, objv, dbenv); + break; + case ENVGETCACHESIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_cachesize(dbenv, &gbytes, &bytes, &ncache); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_cachesize")) == TCL_OK) { + myobjv[0] = Tcl_NewLongObj((long)gbytes); + myobjv[1] = Tcl_NewLongObj((long)bytes); + myobjv[2] = Tcl_NewLongObj((long)ncache); + res = Tcl_NewListObj(3, myobjv); + } + break; + case ENVGETCACHEMAX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_cache_max(dbenv, &gbytes, &bytes); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_cache_max")) == TCL_OK) { + myobjv[0] = Tcl_NewLongObj((long)gbytes); + myobjv[1] = Tcl_NewLongObj((long)bytes); + res = Tcl_NewListObj(2, myobjv); + } + break; + case ENVGETDATADIRS: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_data_dirs(dbenv, &dirs); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_data_dirs")) == TCL_OK) { + res = Tcl_NewListObj(0, NULL); + for (i = 0; result == TCL_OK && dirs[i] != NULL; i++) + result = Tcl_ListObjAppendElement(interp, res, + NewStringObj(dirs[i], strlen(dirs[i]))); + } + break; + case ENVGETENCRYPTFLAGS: + result = tcl_EnvGetEncryptFlags(interp, objc, objv, dbenv); + break; + case ENVGETERRPFX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + dbenv->get_errpfx(dbenv, &strval); + res = NewStringObj(strval, strlen(strval)); + break; + case ENVGETFLAGS: + result = env_GetFlags(interp, objc, objv, dbenv); + break; + case ENVGETHOME: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_home(dbenv, &strval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_home")) == TCL_OK) + res = NewStringObj(strval, strlen(strval)); + break; + case ENVGETLGBSIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lg_bsize(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lg_bsize")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETLGDIR: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lg_dir(dbenv, &strval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lg_dir")) == TCL_OK) + res = NewStringObj(strval, strlen(strval)); + break; + case ENVGETLGFILEMODE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lg_filemode(dbenv, &intvalue); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lg_filemode")) == TCL_OK) + res = Tcl_NewLongObj((long)intvalue); + break; + case ENVGETLGMAX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lg_max(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lg_max")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETLGREGIONMAX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lg_regionmax(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lg_regionmax")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETLKDETECT: + result = env_GetLockDetect(interp, objc, objv, dbenv); + break; + case ENVGETLKMAXLOCKERS: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lk_max_lockers(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lk_max_lockers")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETLKMAXLOCKS: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lk_max_locks(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lk_max_locks")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETLKMAXOBJECTS: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lk_max_objects(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lk_max_objects")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETMPMAXOPENFD: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_mp_max_openfd(dbenv, &intvalue); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_mp_max_openfd")) == TCL_OK) + res = Tcl_NewIntObj(intvalue); + break; + case ENVGETMPMAXWRITE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_mp_max_write(dbenv, &intvalue, &timeout); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_mp_max_write")) == TCL_OK) { + myobjv[0] = Tcl_NewIntObj(intvalue); + myobjv[1] = Tcl_NewIntObj((int)timeout); + res = Tcl_NewListObj(2, myobjv); + } + break; + case ENVGETMPMMAPSIZE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_mp_mmapsize(dbenv, &size); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_mp_mmapsize")) == TCL_OK) + res = Tcl_NewLongObj((long)size); + break; + case ENVGETOPENFLAG: + result = env_GetOpenFlag(interp, objc, objv, dbenv); + break; + case ENVGETSHMKEY: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_shm_key(dbenv, &shm_key); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env shm_key")) == TCL_OK) + res = Tcl_NewLongObj(shm_key); + break; + case ENVGETTASSPINS: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->mutex_get_tas_spins(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_tas_spins")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETTIMEOUT: + result = env_GetTimeout(interp, objc, objv, dbenv); + break; + case ENVGETTMPDIR: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_tmp_dir(dbenv, &strval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_tmp_dir")) == TCL_OK) + res = NewStringObj(strval, strlen(strval)); + break; + case ENVGETTXMAX: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_tx_max(dbenv, &value); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_tx_max")) == TCL_OK) + res = Tcl_NewLongObj((long)value); + break; + case ENVGETTXTIMESTAMP: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_tx_timestamp(dbenv, &timeval); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_tx_timestamp")) == TCL_OK) + res = Tcl_NewLongObj((long)timeval); + break; + case ENVGETVERBOSE: + result = env_GetVerbose(interp, objc, objv, dbenv); + break; + case ENVRESIZECACHE: + if ((result = Tcl_ListObjGetElements( + interp, objv[2], &listobjc, &listobjv)) != TCL_OK) + break; + if (objc != 3 || listobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-resize_cache {gbytes bytes}?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, listobjv[0], &gbytes); + if (result != TCL_OK) + break; + result = _GetUInt32(interp, listobjv[1], &bytes); + if (result != TCL_OK) + break; + ret = dbenv->set_cachesize(dbenv, gbytes, bytes, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "resize_cache"); + break; + case ENVSETDATADIR: + /* + * One args for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "pfx"); + return (TCL_ERROR); + } + strarg = Tcl_GetStringFromObj(objv[2], NULL); + ret = dbenv->set_data_dir(dbenv, strarg); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env set data dir")); + case ENVTXN: + result = tcl_Txn(interp, objc, objv, dbenv, envip); + break; + case ENVTXNCKP: + result = tcl_TxnCheckpoint(interp, objc, objv, dbenv); + 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); +} + +/* + * PUBLIC: int tcl_EnvRemove __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *, DBTCL_INFO *)); + * + * tcl_EnvRemove -- + */ +int +tcl_EnvRemove(interp, objc, objv, dbenv, envip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Env pointer */ + DBTCL_INFO *envip; /* Info pointer */ +{ + static const char *envremopts[] = { +#ifdef CONFIG_TEST + "-overwrite", + "-server", +#endif + "-data_dir", + "-encryptaes", + "-encryptany", + "-force", + "-home", + "-log_dir", + "-tmp_dir", + "-use_environ", + "-use_environ_root", + NULL + }; + enum envremopts { +#ifdef CONFIG_TEST + ENVREM_OVERWRITE, + ENVREM_SERVER, +#endif + ENVREM_DATADIR, + ENVREM_ENCRYPT_AES, + ENVREM_ENCRYPT_ANY, + ENVREM_FORCE, + ENVREM_HOME, + ENVREM_LOGDIR, + ENVREM_TMPDIR, + ENVREM_USE_ENVIRON, + ENVREM_USE_ENVIRON_ROOT + }; + u_int32_t cflag, enc_flag, flag, forceflag, sflag; + int i, optindex, result, ret; + char *datadir, *home, *logdir, *passwd, *server, *tmpdir; + + result = TCL_OK; + cflag = flag = forceflag = sflag = 0; + home = NULL; + passwd = NULL; + datadir = logdir = tmpdir = NULL; + server = NULL; + enc_flag = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], envremopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto error; + } + i++; + switch ((enum envremopts)optindex) { +#ifdef CONFIG_TEST + case ENVREM_SERVER: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-server name?"); + result = TCL_ERROR; + break; + } + server = Tcl_GetStringFromObj(objv[i++], NULL); + cflag = DB_RPCCLIENT; + break; +#endif + case ENVREM_ENCRYPT_AES: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptaes passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = DB_ENCRYPT_AES; + break; + case ENVREM_ENCRYPT_ANY: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-encryptany passwd?"); + result = TCL_ERROR; + break; + } + passwd = Tcl_GetStringFromObj(objv[i++], NULL); + enc_flag = 0; + break; + case ENVREM_FORCE: + forceflag |= DB_FORCE; + break; + case ENVREM_HOME: + /* Make sure we have an arg to check against! */ + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-home dir?"); + result = TCL_ERROR; + break; + } + home = Tcl_GetStringFromObj(objv[i++], NULL); + break; +#ifdef CONFIG_TEST + case ENVREM_OVERWRITE: + sflag |= DB_OVERWRITE; + break; +#endif + case ENVREM_USE_ENVIRON: + flag |= DB_USE_ENVIRON; + break; + case ENVREM_USE_ENVIRON_ROOT: + flag |= DB_USE_ENVIRON_ROOT; + break; + case ENVREM_DATADIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-data_dir dir"); + result = TCL_ERROR; + break; + } + datadir = Tcl_GetStringFromObj(objv[i++], NULL); + break; + case ENVREM_LOGDIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-log_dir dir"); + result = TCL_ERROR; + break; + } + logdir = Tcl_GetStringFromObj(objv[i++], NULL); + break; + case ENVREM_TMPDIR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-tmp_dir dir"); + result = TCL_ERROR; + break; + } + tmpdir = Tcl_GetStringFromObj(objv[i++], NULL); + break; + } + /* + * If, at any time, parsing the args we get an error, + * bail out and return. + */ + if (result != TCL_OK) + goto error; + } + + /* + * If dbenv is NULL, we don't have an open env and we need to open + * one of the user. Don't bother with the info stuff. + */ + if (dbenv == NULL) { + if ((ret = db_env_create(&dbenv, cflag)) != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "db_env_create"); + goto error; + } + if (server != NULL) { + _debug_check(); + ret = dbenv->set_rpc_server( + dbenv, NULL, server, 0, 0, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_rpc_server"); + if (result != TCL_OK) + goto error; + } + if (datadir != NULL) { + _debug_check(); + ret = dbenv->set_data_dir(dbenv, datadir); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_data_dir"); + if (result != TCL_OK) + goto error; + } + if (logdir != NULL) { + _debug_check(); + ret = dbenv->set_lg_dir(dbenv, logdir); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_log_dir"); + if (result != TCL_OK) + goto error; + } + if (tmpdir != NULL) { + _debug_check(); + ret = dbenv->set_tmp_dir(dbenv, tmpdir); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_tmp_dir"); + if (result != TCL_OK) + goto error; + } + if (passwd != NULL) { + ret = dbenv->set_encrypt(dbenv, passwd, enc_flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_encrypt"); + } + if (sflag != 0 && + (ret = dbenv->set_flags(dbenv, sflag, 1)) != 0) { + _debug_check(); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "set_flags"); + if (result != TCL_OK) + goto error; + } + dbenv->set_errpfx(dbenv, "EnvRemove"); + dbenv->set_errcall(dbenv, _ErrorFunc); + } else { + /* + * We have to clean up any info associated with this env, + * regardless of the result of the remove so do it first. + * NOTE: envip is freed when we come back from this function. + */ + _EnvInfoDelete(interp, envip); + envip = NULL; + } + + flag |= forceflag; + /* + * When we get here we have parsed all the args. Now remove + * the environment. + */ + _debug_check(); + ret = dbenv->remove(dbenv, home, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env remove"); +error: + return (result); +} + +static void +_EnvInfoDelete(interp, envip) + Tcl_Interp *interp; /* Tcl Interpreter */ + DBTCL_INFO *envip; /* Info for env */ +{ + DBTCL_INFO *nextp, *p; + + /* + * Before we can delete the environment info, we must close + * any open subsystems in this env. We will: + * 1. Abort any transactions (which aborts any nested txns). + * 2. Close any mpools (which will put any pages itself). + * 3. Put any locks and close log cursors. + * 4. Close the error file. + */ + for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) { + /* + * Check if this info structure "belongs" to this + * env. If so, remove its commands and info structure. + * We do not close/abort/whatever here, because we + * don't want to replicate DB behavior. + * + * NOTE: Only those types that can nest need to be + * itemized in the switch below. That is txns and mps. + * Other types like log cursors and locks will just + * get cleaned up here. + */ + if (p->i_parent == envip) { + switch (p->i_type) { + case I_TXN: + _TxnInfoDelete(interp, p); + break; + case I_MP: + _MpInfoDelete(interp, p); + break; + case I_DB: + case I_DBC: + case I_ENV: + case I_LOCK: + case I_LOGC: + case I_NDBM: + case I_PG: + case I_SEQ: + Tcl_SetResult(interp, + "_EnvInfoDelete: bad info type", + TCL_STATIC); + break; + } + nextp = LIST_NEXT(p, entries); + (void)Tcl_DeleteCommand(interp, p->i_name); + _DeleteInfo(p); + } else + nextp = LIST_NEXT(p, entries); + } + (void)Tcl_DeleteCommand(interp, envip->i_name); + _DeleteInfo(envip); +} + +#ifdef CONFIG_TEST +/* + * PUBLIC: int tcl_EnvIdReset __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_EnvIdReset -- + * Implements the ENV->fileid_reset command. + */ +int +tcl_EnvIdReset(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* arg count */ + Tcl_Obj * CONST* objv; /* args */ + DB_ENV *dbenv; /* Database pointer */ +{ + static const char *idwhich[] = { + "-encrypt", + NULL + }; + enum idwhich { + IDENCRYPT + }; + int enc, i, result, ret; + u_int32_t flags; + char *file; + + result = TCL_OK; + flags = 0; + i = 2; + Tcl_SetResult(interp, "0", TCL_STATIC); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-encrypt? filename"); + return (TCL_ERROR); + } else if (objc > 3) { + /* + * If there is an arg, make sure it is the right one. + */ + if (Tcl_GetIndexFromObj(interp, objv[2], idwhich, "option", + TCL_EXACT, &enc) != TCL_OK) + return (IS_HELP(objv[2])); + switch ((enum idwhich)enc) { + case IDENCRYPT: + flags |= DB_ENCRYPT; + break; + } + i = 3; + } + file = Tcl_GetStringFromObj(objv[i], NULL); + ret = dbenv->fileid_reset(dbenv, file, flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "fileid reset"); + return (result); +} + +/* + * PUBLIC: int tcl_EnvLsnReset __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_EnvLsnReset -- + * Implements the ENV->lsn_reset command. + */ +int +tcl_EnvLsnReset(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* arg count */ + Tcl_Obj * CONST* objv; /* args */ + DB_ENV *dbenv; /* Database pointer */ +{ + static const char *lsnwhich[] = { + "-encrypt", + NULL + }; + enum lsnwhich { + IDENCRYPT + }; + int enc, i, result, ret; + u_int32_t flags; + char *file; + + result = TCL_OK; + flags = 0; + i = 2; + Tcl_SetResult(interp, "0", TCL_STATIC); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-encrypt? filename"); + return (TCL_ERROR); + } else if (objc > 3) { + /* + * If there is an arg, make sure it is the right one. + */ + if (Tcl_GetIndexFromObj(interp, objv[2], lsnwhich, "option", + TCL_EXACT, &enc) != TCL_OK) + return (IS_HELP(objv[2])); + + switch ((enum lsnwhich)enc) { + case IDENCRYPT: + flags |= DB_ENCRYPT; + break; + } + i = 3; + } + file = Tcl_GetStringFromObj(objv[i], NULL); + ret = dbenv->lsn_reset(dbenv, file, flags); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lsn reset"); + return (result); +} + +/* + * PUBLIC: int tcl_EnvVerbose __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *, + * PUBLIC: Tcl_Obj *)); + * + * tcl_EnvVerbose -- + */ +int +tcl_EnvVerbose(interp, dbenv, which, onoff) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Env pointer */ + Tcl_Obj *which; /* Which subsystem */ + Tcl_Obj *onoff; /* On or off */ +{ + static const char *verbwhich[] = { + "deadlock", + "fileops", + "fileops_all", + "recovery", + "register", + "rep", + "rep_elect", + "rep_lease", + "rep_misc", + "rep_msgs", + "rep_sync", + "rep_test", + "repmgr_connfail", + "repmgr_misc", + "wait", + NULL + }; + enum verbwhich { + ENVVERB_DEADLOCK, + ENVVERB_FILEOPS, + ENVVERB_FILEOPS_ALL, + ENVVERB_RECOVERY, + ENVVERB_REGISTER, + ENVVERB_REPLICATION, + ENVVERB_REP_ELECT, + ENVVERB_REP_LEASE, + ENVVERB_REP_MISC, + ENVVERB_REP_MSGS, + ENVVERB_REP_SYNC, + ENVVERB_REP_TEST, + ENVVERB_REPMGR_CONNFAIL, + ENVVERB_REPMGR_MISC, + ENVVERB_WAITSFOR + }; + static const char *verbonoff[] = { + "off", + "on", + NULL + }; + enum verbonoff { + ENVVERB_OFF, + ENVVERB_ON + }; + int on, optindex, ret; + u_int32_t wh; + + if (Tcl_GetIndexFromObj(interp, which, verbwhich, "option", + TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(which)); + + switch ((enum verbwhich)optindex) { + case ENVVERB_DEADLOCK: + wh = DB_VERB_DEADLOCK; + break; + case ENVVERB_FILEOPS: + wh = DB_VERB_FILEOPS; + break; + case ENVVERB_FILEOPS_ALL: + wh = DB_VERB_FILEOPS_ALL; + break; + case ENVVERB_RECOVERY: + wh = DB_VERB_RECOVERY; + break; + case ENVVERB_REGISTER: + wh = DB_VERB_REGISTER; + break; + case ENVVERB_REPLICATION: + wh = DB_VERB_REPLICATION; + break; + case ENVVERB_REP_ELECT: + wh = DB_VERB_REP_ELECT; + break; + case ENVVERB_REP_LEASE: + wh = DB_VERB_REP_LEASE; + break; + case ENVVERB_REP_MISC: + wh = DB_VERB_REP_MISC; + break; + case ENVVERB_REP_MSGS: + wh = DB_VERB_REP_MSGS; + break; + case ENVVERB_REP_SYNC: + wh = DB_VERB_REP_SYNC; + break; + case ENVVERB_REP_TEST: + wh = DB_VERB_REP_TEST; + break; + case ENVVERB_REPMGR_CONNFAIL: + wh = DB_VERB_REPMGR_CONNFAIL; + break; + case ENVVERB_REPMGR_MISC: + wh = DB_VERB_REPMGR_MISC; + break; + case ENVVERB_WAITSFOR: + wh = DB_VERB_WAITSFOR; + break; + default: + return (TCL_ERROR); + } + if (Tcl_GetIndexFromObj(interp, onoff, verbonoff, "option", + TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(onoff)); + switch ((enum verbonoff)optindex) { + case ENVVERB_OFF: + on = 0; + break; + case ENVVERB_ON: + on = 1; + break; + default: + return (TCL_ERROR); + } + ret = dbenv->set_verbose(dbenv, wh, on); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env set verbose")); +} +#endif + +#ifdef CONFIG_TEST +/* + * PUBLIC: int tcl_EnvAttr __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); + * + * tcl_EnvAttr -- + * Return a list of the env's attributes + */ +int +tcl_EnvAttr(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Env pointer */ +{ + ENV *env; + Tcl_Obj *myobj, *retlist; + int result; + + env = dbenv->env; + result = TCL_OK; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + retlist = Tcl_NewListObj(0, NULL); + /* + * XXX + * We peek at the ENV to determine what subsystems we have available + * in this environment. + */ + myobj = NewStringObj("-home", strlen("-home")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + myobj = NewStringObj(env->db_home, strlen(env->db_home)); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + if (CDB_LOCKING(env)) { + myobj = NewStringObj("-cdb", strlen("-cdb")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (CRYPTO_ON(env)) { + myobj = NewStringObj("-crypto", strlen("-crypto")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (LOCKING_ON(env)) { + myobj = NewStringObj("-lock", strlen("-lock")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (LOGGING_ON(env)) { + myobj = NewStringObj("-log", strlen("-log")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (MPOOL_ON(env)) { + myobj = NewStringObj("-mpool", strlen("-mpool")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (RPC_ON(dbenv)) { + myobj = NewStringObj("-rpc", strlen("-rpc")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (REP_ON(env)) { + myobj = NewStringObj("-rep", strlen("-rep")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + if (TXN_ON(env)) { + myobj = NewStringObj("-txn", strlen("-txn")); + if ((result = Tcl_ListObjAppendElement(interp, + retlist, myobj)) != TCL_OK) + goto err; + } + Tcl_SetObjResult(interp, retlist); +err: + return (result); +} + +/* + * tcl_EventNotify -- + * Call DB_ENV->set_event_notify(). + * + * PUBLIC: int tcl_EventNotify __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *, + * PUBLIC: DBTCL_INFO *)); + * + * Note that this normally can/should be achieved as an argument to + * berkdb env, but we need to test changing the event function on + * the fly. + */ +int +tcl_EventNotify(interp, dbenv, eobj, ip) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; + Tcl_Obj *eobj; /* The event proc */ + DBTCL_INFO *ip; +{ + int ret; + + /* + * We don't need to crack the event procedure out now. + */ + /* + * If we're replacing an existing event proc, decrement it now. + */ + if (ip->i_event != NULL) { + Tcl_DecrRefCount(ip->i_event); + } + ip->i_event = eobj; + Tcl_IncrRefCount(ip->i_event); + _debug_check(); + ret = dbenv->set_event_notify(dbenv, _EventFunc); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env event")); +} + +/* + * PUBLIC: int tcl_EnvSetFlags __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *, + * PUBLIC: Tcl_Obj *)); + * + * tcl_EnvSetFlags -- + * Set flags in an env. + */ +int +tcl_EnvSetFlags(interp, dbenv, which, onoff) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Env pointer */ + Tcl_Obj *which; /* Which subsystem */ + Tcl_Obj *onoff; /* On or off */ +{ + static const char *sfwhich[] = { + "-auto_commit", + "-direct_db", + "-multiversion", + "-nolock", + "-nommap", + "-nopanic", + "-nosync", + "-overwrite", + "-panic", + "-wrnosync", + NULL + }; + enum sfwhich { + ENVSF_AUTOCOMMIT, + ENVSF_DIRECTDB, + ENVSF_MULTIVERSION, + ENVSF_NOLOCK, + ENVSF_NOMMAP, + ENVSF_NOPANIC, + ENVSF_NOSYNC, + ENVSF_OVERWRITE, + ENVSF_PANIC, + ENVSF_WRNOSYNC + }; + static const char *sfonoff[] = { + "off", + "on", + NULL + }; + enum sfonoff { + ENVSF_OFF, + ENVSF_ON + }; + int on, optindex, ret; + u_int32_t wh; + + if (Tcl_GetIndexFromObj(interp, which, sfwhich, "option", + TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(which)); + + switch ((enum sfwhich)optindex) { + case ENVSF_AUTOCOMMIT: + wh = DB_AUTO_COMMIT; + break; + case ENVSF_DIRECTDB: + wh = DB_DIRECT_DB; + break; + case ENVSF_MULTIVERSION: + wh = DB_MULTIVERSION; + break; + case ENVSF_NOLOCK: + wh = DB_NOLOCKING; + break; + case ENVSF_NOMMAP: + wh = DB_NOMMAP; + break; + case ENVSF_NOSYNC: + wh = DB_TXN_NOSYNC; + break; + case ENVSF_NOPANIC: + wh = DB_NOPANIC; + break; + case ENVSF_PANIC: + wh = DB_PANIC_ENVIRONMENT; + break; + case ENVSF_OVERWRITE: + wh = DB_OVERWRITE; + break; + case ENVSF_WRNOSYNC: + wh = DB_TXN_WRITE_NOSYNC; + break; + default: + return (TCL_ERROR); + } + if (Tcl_GetIndexFromObj(interp, onoff, sfonoff, "option", + TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(onoff)); + switch ((enum sfonoff)optindex) { + case ENVSF_OFF: + on = 0; + break; + case ENVSF_ON: + on = 1; + break; + default: + return (TCL_ERROR); + } + ret = dbenv->set_flags(dbenv, wh, on); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env set flags")); +} + +/* + * tcl_EnvTest -- + * The "$env test ..." command is a sort of catch-all for any sort of + * desired test hook manipulation. The "abort", "check" and "copy" subcommands + * all set one or another certain location in the DB_ENV handle to a specific + * value. (In the case of "check", the value is an integer passed in with the + * command itself. For the other two, the "value" is a predefined enum + * constant, specified by name.) + * The "$env test force ..." subcommand invokes other, more arbitrary + * manipulations. + * Although these functions may not all seem closely related, putting them + * all under the name "test" has the aesthetic appeal of keeping the rest of the + * API clean. + * + * PUBLIC: int tcl_EnvTest __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); + */ +int +tcl_EnvTest(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Env pointer */ +{ + static const char *envtestcmd[] = { + "abort", + "check", + "copy", + "force", + NULL + }; + enum envtestcmd { + ENVTEST_ABORT, + ENVTEST_CHECK, + ENVTEST_COPY, + ENVTEST_FORCE + }; + static const char *envtestat[] = { + "electinit", + "electvote1", + "none", + "predestroy", + "preopen", + "postdestroy", + "postlog", + "postlogmeta", + "postopen", + "postsync", + "subdb_lock", + NULL + }; + enum envtestat { + ENVTEST_ELECTINIT, + ENVTEST_ELECTVOTE1, + ENVTEST_NONE, + ENVTEST_PREDESTROY, + ENVTEST_PREOPEN, + ENVTEST_POSTDESTROY, + ENVTEST_POSTLOG, + ENVTEST_POSTLOGMETA, + ENVTEST_POSTOPEN, + ENVTEST_POSTSYNC, + ENVTEST_SUBDB_LOCKS + }; + static const char *envtestforce[] = { + "noarchive_timeout", + NULL + }; + enum envtestforce { + ENVTEST_NOARCHIVE_TIMEOUT + }; + ENV *env; + int *loc, optindex, result, testval; + + env = dbenv->env; + result = TCL_OK; + loc = NULL; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, + 2, objv, "abort|check|copy|force <args>"); + return (TCL_ERROR); + } + + /* + * This must be the "check", "copy" or "abort" portion of the command. + */ + if (Tcl_GetIndexFromObj(interp, objv[2], envtestcmd, "command", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[2]); + return (result); + } + switch ((enum envtestcmd)optindex) { + case ENVTEST_ABORT: + loc = &env->test_abort; + break; + case ENVTEST_CHECK: + loc = &env->test_check; + if (Tcl_GetIntFromObj(interp, objv[3], &testval) != TCL_OK) { + result = IS_HELP(objv[3]); + return (result); + } + goto done; + case ENVTEST_COPY: + loc = &env->test_copy; + break; + case ENVTEST_FORCE: + if (Tcl_GetIndexFromObj(interp, objv[3], envtestforce, "arg", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[3]); + return (result); + } + /* + * In the future we might add more, and then we'd use a switch + * statement. + */ + DB_ASSERT(env, + (enum envtestforce)optindex == ENVTEST_NOARCHIVE_TIMEOUT); + return (tcl_RepNoarchiveTimeout(interp, dbenv)); + default: + Tcl_SetResult(interp, "Illegal store location", TCL_STATIC); + return (TCL_ERROR); + } + + /* + * This must be the location portion of the command. + */ + if (Tcl_GetIndexFromObj(interp, objv[3], envtestat, "location", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[3]); + return (result); + } + switch ((enum envtestat)optindex) { + case ENVTEST_ELECTINIT: + DB_ASSERT(env, loc == &env->test_abort); + testval = DB_TEST_ELECTINIT; + break; + case ENVTEST_ELECTVOTE1: + DB_ASSERT(env, loc == &env->test_abort); + testval = DB_TEST_ELECTVOTE1; + break; + case ENVTEST_NONE: + testval = 0; + break; + case ENVTEST_PREOPEN: + testval = DB_TEST_PREOPEN; + break; + case ENVTEST_PREDESTROY: + testval = DB_TEST_PREDESTROY; + break; + case ENVTEST_POSTLOG: + testval = DB_TEST_POSTLOG; + break; + case ENVTEST_POSTLOGMETA: + testval = DB_TEST_POSTLOGMETA; + break; + case ENVTEST_POSTOPEN: + testval = DB_TEST_POSTOPEN; + break; + case ENVTEST_POSTDESTROY: + testval = DB_TEST_POSTDESTROY; + break; + case ENVTEST_POSTSYNC: + testval = DB_TEST_POSTSYNC; + break; + case ENVTEST_SUBDB_LOCKS: + DB_ASSERT(env, loc == &env->test_abort); + testval = DB_TEST_SUBDB_LOCKS; + break; + default: + Tcl_SetResult(interp, "Illegal test location", TCL_STATIC); + return (TCL_ERROR); + } +done: + *loc = testval; + Tcl_SetResult(interp, "0", TCL_STATIC); + return (result); +} +#endif + +/* + * env_DbRemove -- + * Implements the ENV->dbremove command. + */ +static int +env_DbRemove(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + static const char *envdbrem[] = { + "-auto_commit", + "-notdurable", + "-txn", + "--", + NULL + }; + enum envdbrem { + TCL_EDBREM_COMMIT, + TCL_EDBREM_NOTDURABLE, + TCL_EDBREM_TXN, + TCL_EDBREM_ENDARG + }; + DB_TXN *txn; + u_int32_t flag; + int endarg, i, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, *subdb, msg[MSG_SIZE]; + + txn = NULL; + result = TCL_OK; + subdbtmp = NULL; + db = subdb = NULL; + endarg = 0; + flag = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], envdbrem, + "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 envdbrem)optindex) { + case TCL_EDBREM_COMMIT: + flag |= DB_AUTO_COMMIT; + break; + case TCL_EDBREM_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, + "env dbremove: Invalid txn %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + break; + case TCL_EDBREM_ENDARG: + endarg = 1; + break; + case TCL_EDBREM_NOTDURABLE: + flag |= DB_TXN_NOT_DURABLE; + 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 1 or 2 left) are + * file names. If there is 1, a db name, if 2 a db and subdb name. + */ + if ((i != (objc - 1)) || (i != (objc - 2))) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i != objc) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc( + dbenv->env, (size_t)subdblen + 1, &subdb)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?"); + result = TCL_ERROR; + goto error; + } + ret = dbenv->dbremove(dbenv, txn, db, subdb, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env dbremove"); +error: + if (subdb) + __os_free(dbenv->env, subdb); + return (result); +} + +/* + * env_DbRename -- + * Implements the ENV->dbrename command. + */ +static int +env_DbRename(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + static const char *envdbmv[] = { + "-auto_commit", + "-txn", + "--", + NULL + }; + enum envdbmv { + TCL_EDBMV_COMMIT, + TCL_EDBMV_TXN, + TCL_EDBMV_ENDARG + }; + DB_TXN *txn; + u_int32_t flag; + int endarg, i, newlen, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, *newname, *subdb, msg[MSG_SIZE]; + + txn = NULL; + result = TCL_OK; + subdbtmp = NULL; + db = newname = subdb = NULL; + endarg = 0; + flag = 0; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 3, objv, + "?args? filename ?database? ?newname?"); + return (TCL_ERROR); + } + + /* + * We must first parse for the environment flag, since that + * is needed for db_create. Then create the db handle. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], envdbmv, + "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 envdbmv)optindex) { + case TCL_EDBMV_COMMIT: + flag |= DB_AUTO_COMMIT; + break; + case TCL_EDBMV_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, + "env dbrename: Invalid txn %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + break; + case TCL_EDBMV_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 2 or 3 left) are + * file names. If there is 2, a db name, if 3 a db and subdb name. + */ + if ((i != (objc - 2)) || (i != (objc - 3))) { + /* + * Dbs must be NULL terminated file names, but subdbs can + * be anything. Use Strings for the db name and byte + * arrays for the subdb. + */ + db = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(db, "") == 0) + db = NULL; + if (i == objc - 2) { + subdbtmp = + Tcl_GetByteArrayFromObj(objv[i++], &subdblen); + if ((ret = __os_malloc( + dbenv->env, (size_t)subdblen + 1, &subdb)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, (size_t)subdblen); + subdb[subdblen] = '\0'; + } + subdbtmp = Tcl_GetByteArrayFromObj(objv[i++], &newlen); + if ((ret = __os_malloc( + dbenv->env, (size_t)newlen + 1, &newname)) != 0) { + Tcl_SetResult(interp, + db_strerror(ret), TCL_STATIC); + return (0); + } + memcpy(newname, subdbtmp, (size_t)newlen); + newname[newlen] = '\0'; + } else { + Tcl_WrongNumArgs(interp, 3, objv, + "?args? filename ?database? ?newname?"); + result = TCL_ERROR; + goto error; + } + ret = dbenv->dbrename(dbenv, txn, db, subdb, newname, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env dbrename"); +error: + if (subdb) + __os_free(dbenv->env, subdb); + if (newname) + __os_free(dbenv->env, newname); + return (result); +} + +/* + * env_GetFlags -- + * Implements the ENV->get_flags command. + */ +static int +env_GetFlags(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + int i, ret, result; + u_int32_t flags; + char buf[512]; + Tcl_Obj *res; + + static const struct { + u_int32_t flag; + char *arg; + } open_flags[] = { + { DB_AUTO_COMMIT, "-auto_commit" }, + { DB_CDB_ALLDB, "-cdb_alldb" }, + { DB_DIRECT_DB, "-direct_db" }, + { DB_MULTIVERSION, "-multiversion" }, + { DB_NOLOCKING, "-nolock" }, + { DB_NOMMAP, "-nommap" }, + { DB_NOPANIC, "-nopanic" }, + { DB_OVERWRITE, "-overwrite" }, + { DB_PANIC_ENVIRONMENT, "-panic" }, + { DB_REGION_INIT, "-region_init" }, + { DB_TXN_NOSYNC, "-nosync" }, + { DB_TXN_WRITE_NOSYNC, "-wrnosync" }, + { DB_YIELDCPU, "-yield" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + ret = dbenv->get_flags(dbenv, &flags); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_flags")) == TCL_OK) { + buf[0] = '\0'; + + for (i = 0; open_flags[i].flag != 0; i++) + if (LF_ISSET(open_flags[i].flag)) { + if (strlen(buf) > 0) + (void)strncat(buf, " ", sizeof(buf)); + (void)strncat( + buf, open_flags[i].arg, sizeof(buf)); + } + + res = NewStringObj(buf, strlen(buf)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * env_GetOpenFlag -- + * Implements the ENV->get_open_flags command. + */ +static int +env_GetOpenFlag(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + int i, ret, result; + u_int32_t flags; + char buf[512]; + Tcl_Obj *res; + + static const struct { + u_int32_t flag; + char *arg; + } open_flags[] = { + { DB_CREATE, "-create" }, + { DB_FAILCHK, "-failchk" }, + { DB_INIT_CDB, "-cdb" }, + { DB_INIT_LOCK, "-lock" }, + { DB_INIT_LOG, "-log" }, + { DB_INIT_MPOOL, "-mpool" }, + { DB_INIT_REP, "-rep" }, + { DB_INIT_TXN, "-txn" }, + { DB_LOCKDOWN, "-lockdown" }, + { DB_PRIVATE, "-private" }, + { DB_RECOVER, "-recover" }, + { DB_RECOVER_FATAL, "-recover_fatal" }, + { DB_REGISTER, "-register" }, + { DB_FAILCHK, "-failchk" }, + { DB_SYSTEM_MEM, "-system_mem" }, + { DB_THREAD, "-thread" }, + { DB_USE_ENVIRON, "-use_environ" }, + { DB_USE_ENVIRON_ROOT, "-use_environ_root" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + ret = dbenv->get_open_flags(dbenv, &flags); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_open_flags")) == TCL_OK) { + buf[0] = '\0'; + + for (i = 0; open_flags[i].flag != 0; i++) + if (LF_ISSET(open_flags[i].flag)) { + if (strlen(buf) > 0) + (void)strncat(buf, " ", sizeof(buf)); + (void)strncat( + buf, open_flags[i].arg, sizeof(buf)); + } + + res = NewStringObj(buf, strlen(buf)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * PUBLIC: int tcl_EnvGetEncryptFlags __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_EnvGetEncryptFlags -- + * Implements the ENV->get_encrypt_flags command. + */ +int +tcl_EnvGetEncryptFlags(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Database pointer */ +{ + int i, ret, result; + u_int32_t flags; + char buf[512]; + Tcl_Obj *res; + + static const struct { + u_int32_t flag; + char *arg; + } encrypt_flags[] = { + { DB_ENCRYPT_AES, "-encryptaes" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + ret = dbenv->get_encrypt_flags(dbenv, &flags); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_encrypt_flags")) == TCL_OK) { + buf[0] = '\0'; + + for (i = 0; encrypt_flags[i].flag != 0; i++) + if (LF_ISSET(encrypt_flags[i].flag)) { + if (strlen(buf) > 0) + (void)strncat(buf, " ", sizeof(buf)); + (void)strncat( + buf, encrypt_flags[i].arg, sizeof(buf)); + } + + res = NewStringObj(buf, strlen(buf)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * env_GetLockDetect -- + * Implements the ENV->get_lk_detect command. + */ +static int +env_GetLockDetect(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + int i, ret, result; + u_int32_t lk_detect; + const char *answer; + Tcl_Obj *res; + static const struct { + u_int32_t flag; + char *name; + } lk_detect_returns[] = { + { DB_LOCK_DEFAULT, "default" }, + { DB_LOCK_EXPIRE, "expire" }, + { DB_LOCK_MAXLOCKS, "maxlocks" }, + { DB_LOCK_MAXWRITE, "maxwrite" }, + { DB_LOCK_MINLOCKS, "minlocks" }, + { DB_LOCK_MINWRITE, "minwrite" }, + { DB_LOCK_OLDEST, "oldest" }, + { DB_LOCK_RANDOM, "random" }, + { DB_LOCK_YOUNGEST, "youngest" }, + { 0, NULL } + }; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + ret = dbenv->get_lk_detect(dbenv, &lk_detect); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_lk_detect")) == TCL_OK) { + answer = "unknown"; + for (i = 0; lk_detect_returns[i].flag != 0; i++) + if (lk_detect == lk_detect_returns[i].flag) + answer = lk_detect_returns[i].name; + + res = NewStringObj(answer, strlen(answer)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * env_GetTimeout -- + * Implements the ENV->get_timeout command. + */ +static int +env_GetTimeout(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + static const struct { + u_int32_t flag; + char *arg; + } timeout_flags[] = { + { DB_SET_LOCK_TIMEOUT, "lock" }, + { DB_SET_REG_TIMEOUT, "reg" }, + { DB_SET_TXN_TIMEOUT, "txn" }, + { 0, NULL } + }; + Tcl_Obj *res; + db_timeout_t timeout; + u_int32_t which; + int i, ret, result; + const char *arg; + + COMPQUIET(timeout, 0); + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + arg = Tcl_GetStringFromObj(objv[2], NULL); + which = 0; + for (i = 0; timeout_flags[i].flag != 0; i++) + if (strcmp(arg, timeout_flags[i].arg) == 0) + which = timeout_flags[i].flag; + if (which == 0) { + ret = EINVAL; + goto err; + } + + ret = dbenv->get_timeout(dbenv, &timeout, which); +err: if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_timeout")) == TCL_OK) { + res = Tcl_NewLongObj((long)timeout); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * env_GetVerbose -- + * Implements the ENV->get_open_flags command. + */ +static int +env_GetVerbose(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + static const struct { + u_int32_t flag; + char *arg; + } verbose_flags[] = { + { DB_VERB_DEADLOCK, "deadlock" }, + { DB_VERB_FILEOPS, "fileops" }, + { DB_VERB_FILEOPS_ALL, "fileops_all" }, + { DB_VERB_RECOVERY, "recovery" }, + { DB_VERB_REGISTER, "register" }, + { DB_VERB_REPLICATION, "rep" }, + { DB_VERB_REP_ELECT, "rep_elect" }, + { DB_VERB_REP_LEASE, "rep_lease" }, + { DB_VERB_REP_MISC, "rep_misc" }, + { DB_VERB_REP_MSGS, "rep_msgs" }, + { DB_VERB_REP_SYNC, "rep_sync" }, + { DB_VERB_REP_TEST, "rep_test" }, + { DB_VERB_REPMGR_CONNFAIL, "repmgr_connfail" }, + { DB_VERB_REPMGR_MISC, "repmgr_misc" }, + { DB_VERB_WAITSFOR, "wait" }, + { 0, NULL } + }; + Tcl_Obj *res; + u_int32_t which; + int i, onoff, ret, result; + const char *arg, *answer; + + COMPQUIET(onoff, 0); + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + + arg = Tcl_GetStringFromObj(objv[2], NULL); + which = 0; + for (i = 0; verbose_flags[i].flag != 0; i++) + if (strcmp(arg, verbose_flags[i].arg) == 0) + which = verbose_flags[i].flag; + if (which == 0) { + ret = EINVAL; + goto err; + } + + ret = dbenv->get_verbose(dbenv, which, &onoff); +err: if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env get_verbose")) == 0) { + answer = onoff ? "on" : "off"; + res = NewStringObj(answer, strlen(answer)); + Tcl_SetObjResult(interp, res); + } + + return (result); +} + +/* + * PUBLIC: void tcl_EnvSetErrfile __P((Tcl_Interp *, DB_ENV *, DBTCL_INFO *, + * PUBLIC: char *)); + * + * tcl_EnvSetErrfile -- + * Implements the ENV->set_errfile command. + */ +void +tcl_EnvSetErrfile(interp, dbenv, ip, errf) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Database pointer */ + DBTCL_INFO *ip; /* Our internal info */ + char *errf; +{ + COMPQUIET(interp, NULL); + /* + * If the user already set one, free it. + */ + if (ip->i_err != NULL && ip->i_err != stdout && + ip->i_err != stderr) + (void)fclose(ip->i_err); + if (strcmp(errf, "/dev/stdout") == 0) + ip->i_err = stdout; + else if (strcmp(errf, "/dev/stderr") == 0) + ip->i_err = stderr; + else + ip->i_err = fopen(errf, "a"); + if (ip->i_err != NULL) + dbenv->set_errfile(dbenv, ip->i_err); +} + +/* + * PUBLIC: int tcl_EnvSetErrpfx __P((Tcl_Interp *, DB_ENV *, DBTCL_INFO *, + * PUBLIC: char *)); + * + * tcl_EnvSetErrpfx -- + * Implements the ENV->set_errpfx command. + */ +int +tcl_EnvSetErrpfx(interp, dbenv, ip, pfx) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Database pointer */ + DBTCL_INFO *ip; /* Our internal info */ + char *pfx; +{ + int result, ret; + + /* + * Assume success. The only thing that can fail is + * the __os_strdup. + */ + result = TCL_OK; + Tcl_SetResult(interp, "0", TCL_STATIC); + /* + * If the user already set one, free it. + */ + if (ip->i_errpfx != NULL) + __os_free(dbenv->env, ip->i_errpfx); + if ((ret = __os_strdup(dbenv->env, pfx, &ip->i_errpfx)) != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_STD(ret), "__os_strdup"); + ip->i_errpfx = NULL; + } + if (ip->i_errpfx != NULL) + dbenv->set_errpfx(dbenv, ip->i_errpfx); + return (result); +} diff --git a/tcl/tcl_internal.c b/tcl/tcl_internal.c new file mode 100644 index 0000000..d5a3e99 --- /dev/null +++ b/tcl/tcl_internal.c @@ -0,0 +1,817 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_part_callback != NULL) { + Tcl_DecrRefCount(p->i_part_callback); + } + 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, <mp); + 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); +} diff --git a/tcl/tcl_lock.c b/tcl/tcl_lock.c new file mode 100644 index 0000000..03b1bed --- /dev/null +++ b/tcl/tcl_lock.c @@ -0,0 +1,775 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_WSTAT_LIST("Maximum number of lock steals for an empty partition", + sp->st_locksteals); + MAKE_WSTAT_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_WSTAT_LIST("Maximum number of object steals for an empty partition", + sp->st_objectsteals); + MAKE_WSTAT_LIST("Maximum number object steals in any partition", + sp->st_maxosteals); + MAKE_WSTAT_LIST("Lock requests", sp->st_nrequests); + MAKE_WSTAT_LIST("Lock releases", sp->st_nreleases); + MAKE_WSTAT_LIST("Lock upgrades", sp->st_nupgrade); + MAKE_WSTAT_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_WSTAT_LIST("Deadlocks detected", sp->st_ndeadlocks); + MAKE_WSTAT_LIST("Number of region lock waits", sp->st_region_wait); + MAKE_WSTAT_LIST("Number of region lock nowaits", sp->st_region_nowait); + MAKE_WSTAT_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_WSTAT_LIST("Maximum hash bucket length", sp->st_hash_len); + MAKE_STAT_LIST("Lock timeout value", sp->st_locktimeout); + MAKE_WSTAT_LIST("Number of lock timeouts", sp->st_nlocktimeouts); + MAKE_STAT_LIST("Transaction timeout value", sp->st_txntimeout); + MAKE_WSTAT_LIST("Number of transaction timeouts", sp->st_ntxntimeouts); + MAKE_WSTAT_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 diff --git a/tcl/tcl_log.c b/tcl/tcl_log.c new file mode 100644 index 0000000..3b77208 --- /dev/null +++ b/tcl/tcl_log.c @@ -0,0 +1,770 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_WSTAT_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_WSTAT_LIST("Times log written", sp->st_wcount); + MAKE_STAT_LIST("Times log written because cache filled up", + sp->st_wcount_fill); + MAKE_WSTAT_LIST("Times log read from disk", sp->st_rcount); + MAKE_WSTAT_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_WSTAT_LIST("Number of region lock waits", sp->st_region_wait); + MAKE_WSTAT_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 diff --git a/tcl/tcl_mp.c b/tcl/tcl_mp.c new file mode 100644 index 0000000..5c6488f --- /dev/null +++ b/tcl/tcl_mp.c @@ -0,0 +1,939 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_WSTAT_LIST("Cache hits", sp->st_cache_hit); + MAKE_WSTAT_LIST("Cache misses", sp->st_cache_miss); + MAKE_WSTAT_LIST("Pages created", sp->st_page_create); + MAKE_WSTAT_LIST("Pages read in", sp->st_page_in); + MAKE_WSTAT_LIST("Pages written", sp->st_page_out); + MAKE_WSTAT_LIST("Clean page evictions", sp->st_ro_evict); + MAKE_WSTAT_LIST("Dirty page evictions", sp->st_rw_evict); + MAKE_WSTAT_LIST("Dirty pages trickled", sp->st_page_trickle); + MAKE_STAT_LIST("Cached pages", sp->st_pages); + MAKE_WSTAT_LIST("Cached clean pages", sp->st_page_clean); + MAKE_WSTAT_LIST("Cached dirty pages", sp->st_page_dirty); + MAKE_WSTAT_LIST("Hash buckets", sp->st_hash_buckets); + MAKE_WSTAT_LIST("Default pagesize", sp->st_pagesize); + MAKE_WSTAT_LIST("Hash lookups", sp->st_hash_searches); + MAKE_WSTAT_LIST("Longest hash chain found", sp->st_hash_longest); + MAKE_WSTAT_LIST("Hash elements examined", sp->st_hash_examined); + MAKE_WSTAT_LIST("Number of hash bucket nowaits", sp->st_hash_nowait); + MAKE_WSTAT_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_WSTAT_LIST("Number of region lock nowaits", sp->st_region_nowait); + MAKE_WSTAT_LIST("Number of region lock waits", sp->st_region_wait); + MAKE_WSTAT_LIST("Buffers frozen", sp->st_mvcc_frozen); + MAKE_WSTAT_LIST("Buffers thawed", sp->st_mvcc_thawed); + MAKE_WSTAT_LIST("Frozen buffers freed", sp->st_mvcc_freed); + MAKE_WSTAT_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_WSTAT_LIST("Pages examined during allocation", sp->st_alloc_pages); + MAKE_STAT_LIST("Maximum pages examined during allocation", + sp->st_alloc_max_pages); + MAKE_WSTAT_LIST("Threads waiting on buffer I/O", sp->st_io_wait); + MAKE_WSTAT_LIST("Number of syncs interrupted", sp->st_sync_interrupted); + + /* + * 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(); + MAKE_STAT_STRLIST("File Name", (*fsp)->file_name); + MAKE_STAT_LIST("Page size", (*fsp)->st_pagesize); + MAKE_STAT_LIST("Pages mapped into address space", + (*fsp)->st_map); + MAKE_WSTAT_LIST("Cache hits", (*fsp)->st_cache_hit); + MAKE_WSTAT_LIST("Cache misses", (*fsp)->st_cache_miss); + MAKE_WSTAT_LIST("Pages created", (*fsp)->st_page_create); + MAKE_WSTAT_LIST("Pages read in", (*fsp)->st_page_in); + MAKE_WSTAT_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 diff --git a/tcl/tcl_mutex.c b/tcl/tcl_mutex.c new file mode 100644 index 0000000..c05b208 --- /dev/null +++ b/tcl/tcl_mutex.c @@ -0,0 +1,315 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 2004-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#include "db_config.h" + +#include "db_int.h" +#ifdef HAVE_SYSTEM_INCLUDE_FILES +#include <tcl.h> +#endif +#include "dbinc/tcl_db.h" + +#ifdef CONFIG_TEST +/* + * PUBLIC: int tcl_Mutex __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_Mutex -- + * Implements dbenv->mutex_alloc method. + */ +int +tcl_Mutex(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Environment */ +{ + static const char *which[] = { + "-process_only", + "-self_block", + NULL + }; + enum which { + PROCONLY, + SELFBLOCK + }; + int arg, i, result, ret; + u_int32_t flags; + db_mutex_t indx; + Tcl_Obj *res; + + result = TCL_OK; + flags = 0; + Tcl_ResetResult(interp); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "-proccess_only | -self_block"); + return (TCL_ERROR); + } + + i = 2; + while (i < objc) { + /* + * If there is an arg, make sure it is the right one. + */ + if (Tcl_GetIndexFromObj(interp, objv[i], which, "option", + TCL_EXACT, &arg) != TCL_OK) + return (IS_HELP(objv[i])); + i++; + switch ((enum which)arg) { + case PROCONLY: + flags |= DB_MUTEX_PROCESS_ONLY; + break; + case SELFBLOCK: + flags |= DB_MUTEX_SELF_BLOCK; + break; + } + } + res = NULL; + ret = dbenv->mutex_alloc(dbenv, flags, &indx); + if (ret != 0) { + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "mutex_alloc"); + Tcl_SetResult(interp, "allocation failed", TCL_STATIC); + } else { + res = Tcl_NewWideIntObj((Tcl_WideInt)indx); + Tcl_SetObjResult(interp, res); + } + return (result); +} + +/* + * PUBLIC: int tcl_MutFree __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_MutFree -- + * Implements dbenv->mutex_free method. + */ +int +tcl_MutFree(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Environment */ +{ + int result, ret; + db_mutex_t indx; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "mutexid"); + return (TCL_ERROR); + } + if ((result = _GetUInt32(interp, objv[2], &indx)) != TCL_OK) + return (result); + ret = dbenv->mutex_free(dbenv, indx); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_free")); +} + +/* + * PUBLIC: int tcl_MutGet __P((Tcl_Interp *, DB_ENV *, int)); + * + * tcl_MutGet -- + * Implements dbenv->mutex_get_* methods. + */ +int +tcl_MutGet(interp, dbenv, op) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment */ + int op; /* Which item to get */ +{ + Tcl_Obj *res; + u_int32_t val; + int result, ret; + + res = NULL; + val = 0; + ret = 0; + + switch (op) { + case DBTCL_MUT_ALIGN: + ret = dbenv->mutex_get_align(dbenv, &val); + break; + case DBTCL_MUT_INCR: + ret = dbenv->mutex_get_increment(dbenv, &val); + break; + case DBTCL_MUT_MAX: + ret = dbenv->mutex_get_max(dbenv, &val); + break; + case DBTCL_MUT_TAS: + ret = dbenv->mutex_get_tas_spins(dbenv, &val); + break; + default: + return (TCL_ERROR); + } + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "mutex_get")) == TCL_OK) { + res = Tcl_NewLongObj((long)val); + Tcl_SetObjResult(interp, res); + } + return (result); +} + +/* + * PUBLIC: int tcl_MutLock __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_MutLock -- + * Implements dbenv->mutex_lock method. + */ +int +tcl_MutLock(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Environment */ +{ + int result, ret; + db_mutex_t indx; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "mutexid"); + return (TCL_ERROR); + } + if ((result = _GetUInt32(interp, objv[2], &indx)) != TCL_OK) + return (result); + ret = dbenv->mutex_lock(dbenv, indx); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_lock")); +} + +/* + * PUBLIC: int tcl_MutSet __P((Tcl_Interp *, Tcl_Obj *, + * PUBLIC: DB_ENV *, int)); + * + * tcl_MutSet -- + * Implements dbenv->mutex_set methods. + */ +int +tcl_MutSet(interp, obj, dbenv, op) + Tcl_Interp *interp; /* Interpreter */ + Tcl_Obj *obj; /* The argument object */ + DB_ENV *dbenv; /* Environment */ + int op; /* Which item to set */ +{ + int result, ret; + u_int32_t val; + + if ((result = _GetUInt32(interp, obj, &val)) != TCL_OK) + return (result); + switch (op) { + case DBTCL_MUT_ALIGN: + ret = dbenv->mutex_set_align(dbenv, val); + break; + case DBTCL_MUT_INCR: + ret = dbenv->mutex_set_increment(dbenv, val); + break; + case DBTCL_MUT_MAX: + ret = dbenv->mutex_set_max(dbenv, val); + break; + case DBTCL_MUT_TAS: + ret = dbenv->mutex_set_tas_spins(dbenv, val); + break; + default: + return (TCL_ERROR); + } + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_set")); +} + +/* + * PUBLIC: int tcl_MutStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_MutStat -- + * Implements dbenv->mutex_stat method. + */ +int +tcl_MutStat(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Environment */ +{ + DB_MUTEX_STAT *sp; + Tcl_Obj *res; + u_int32_t flag; + 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 = dbenv->mutex_stat(dbenv, &sp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mutex stat"); + if (result == TCL_ERROR) + return (result); + + res = Tcl_NewObj(); + MAKE_STAT_LIST("Mutex align", sp->st_mutex_align); + MAKE_STAT_LIST("Mutex TAS spins", sp->st_mutex_tas_spins); + MAKE_STAT_LIST("Mutex count", sp->st_mutex_cnt); + MAKE_STAT_LIST("Free mutexes", sp->st_mutex_free); + MAKE_STAT_LIST("Mutexes in use", sp->st_mutex_inuse); + MAKE_STAT_LIST("Max in use", sp->st_mutex_inuse_max); + MAKE_STAT_LIST("Mutex region size", sp->st_regsize); + MAKE_WSTAT_LIST("Number of region waits", sp->st_region_wait); + MAKE_WSTAT_LIST("Number of region no waits", sp->st_region_nowait); + Tcl_SetObjResult(interp, res); + + /* + * The 'error' label is used by the MAKE_STAT_LIST macro. + * Therefore we cannot remove it, and also we know that + * sp is allocated at that time. + */ +error: __os_ufree(dbenv->env, sp); + return (result); +} + +/* + * PUBLIC: int tcl_MutUnlock __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + * PUBLIC: DB_ENV *)); + * + * tcl_MutUnlock -- + * Implements dbenv->mutex_unlock method. + */ +int +tcl_MutUnlock(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; /* Environment */ +{ + int result, ret; + db_mutex_t indx; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "mutexid"); + return (TCL_ERROR); + } + if ((result = _GetUInt32(interp, objv[2], &indx)) != TCL_OK) + return (result); + ret = dbenv->mutex_unlock(dbenv, indx); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env mutex_unlock")); +} +#endif diff --git a/tcl/tcl_rep.c b/tcl/tcl_rep.c new file mode 100644 index 0000000..37619fd --- /dev/null +++ b/tcl/tcl_rep.c @@ -0,0 +1,1426 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#include "db_config.h" + +#include "db_int.h" +#ifdef HAVE_SYSTEM_INCLUDE_FILES +#include <tcl.h> +#endif +#include "dbinc/tcl_db.h" + +#ifdef CONFIG_TEST +/* + * tcl_RepConfig -- + * Call DB_ENV->rep_set_config(). + * + * PUBLIC: int tcl_RepConfig + * PUBLIC: __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *)); + */ +int +tcl_RepConfig(interp, dbenv, list) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment pointer */ + Tcl_Obj *list; /* {which on|off} */ +{ + static const char *confwhich[] = { + "bulk", + "delayclient", + "mgr2sitestrict", + "noautoinit", + "nowait", + NULL + }; + enum confwhich { + REPCONF_BULK, + REPCONF_DELAYCLIENT, + REPCONF_MGR2SITESTRICT, + REPCONF_NOAUTOINIT, + REPCONF_NOWAIT + }; + static const char *confonoff[] = { + "off", + "on", + NULL + }; + enum confonoff { + REPCONF_OFF, + REPCONF_ON + }; + Tcl_Obj **myobjv, *onoff, *which; + int myobjc, on, optindex, result, ret; + u_int32_t wh; + + result = Tcl_ListObjGetElements(interp, list, &myobjc, &myobjv); + 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 confwhich)optindex) { + case REPCONF_NOAUTOINIT: + wh = DB_REP_CONF_NOAUTOINIT; + break; + case REPCONF_BULK: + wh = DB_REP_CONF_BULK; + break; + case REPCONF_DELAYCLIENT: + wh = DB_REP_CONF_DELAYCLIENT; + break; + case REPCONF_MGR2SITESTRICT: + wh = DB_REPMGR_CONF_2SITE_STRICT; + break; + case REPCONF_NOWAIT: + wh = DB_REP_CONF_NOWAIT; + 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 REPCONF_OFF: + on = 0; + break; + case REPCONF_ON: + on = 1; + break; + default: + return (TCL_ERROR); + } + ret = dbenv->rep_set_config(dbenv, wh, on); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_config")); +} + +/* + * tcl_RepGetTwo -- + * Call replication getters that return 2 values. + * + * PUBLIC: int tcl_RepGetTwo + * PUBLIC: __P((Tcl_Interp *, DB_ENV *, int)); + */ +int +tcl_RepGetTwo(interp, dbenv, op) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment pointer */ + int op; /* which getter */ +{ + Tcl_Obj *myobjv[2], *res; + u_int32_t val1, val2; + int myobjc, result, ret; + + ret = 0; + val1 = val2 = 0; + switch (op) { + case DBTCL_GETCLOCK: + ret = dbenv->rep_get_clockskew(dbenv, &val1, &val2); + break; + case DBTCL_GETLIMIT: + ret = dbenv->rep_get_limit(dbenv, &val1, &val2); + break; + case DBTCL_GETREQ: + ret = dbenv->rep_get_request(dbenv, &val1, &val2); + break; + default: + return (TCL_ERROR); + } + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_get")) == TCL_OK) { + myobjc = 2; + myobjv[0] = Tcl_NewLongObj((long)val1); + myobjv[1] = Tcl_NewLongObj((long)val2); + res = Tcl_NewListObj(myobjc, myobjv); + Tcl_SetObjResult(interp, res); + } + return (result); +} + +/* + * tcl_RepGetConfig -- + * + * PUBLIC: int tcl_RepGetConfig + * PUBLIC: __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *)); + */ +int +tcl_RepGetConfig(interp, dbenv, which) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment pointer */ + Tcl_Obj *which; /* which flag */ +{ + static const char *confwhich[] = { + "bulk", + "delayclient", + "inmem_files", + "lease", + "mgr2sitestrict", + "noautoinit", + "nowait", + NULL + }; + enum confwhich { + REPGCONF_BULK, + REPGCONF_DELAYCLIENT, + REPGCONF_INMEM_FILES, + REPGCONF_LEASE, + REPGCONF_MGR2SITESTRICT, + REPGCONF_NOAUTOINIT, + REPGCONF_NOWAIT + }; + 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 confwhich)optindex) { + case REPGCONF_BULK: + wh = DB_REP_CONF_BULK; + break; + case REPGCONF_DELAYCLIENT: + wh = DB_REP_CONF_DELAYCLIENT; + break; + case REPGCONF_INMEM_FILES: + wh = DB_REP_CONF_INMEM; + break; + case REPGCONF_LEASE: + wh = DB_REP_CONF_LEASE; + break; + case REPGCONF_MGR2SITESTRICT: + wh = DB_REPMGR_CONF_2SITE_STRICT; + break; + case REPGCONF_NOAUTOINIT: + wh = DB_REP_CONF_NOAUTOINIT; + break; + case REPGCONF_NOWAIT: + wh = DB_REP_CONF_NOWAIT; + break; + default: + return (TCL_ERROR); + } + ret = dbenv->rep_get_config(dbenv, wh, &on); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_config")) == TCL_OK) { + res = Tcl_NewIntObj(on); + Tcl_SetObjResult(interp, res); + } + return (result); +} + +/* + * tcl_RepGetTimeout -- + * Get various replication timeout values. + * + * PUBLIC: int tcl_RepGetTimeout + * PUBLIC: __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *)); + */ +int +tcl_RepGetTimeout(interp, dbenv, which) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment pointer */ + Tcl_Obj *which; /* which flag */ +{ + static const char *towhich[] = { + "ack", + "checkpoint_delay", + "connection_retry", + "election", + "election_retry", + "full_election", + "heartbeat_monitor", + "heartbeat_send", + "lease", + NULL + }; + enum towhich { + REPGTO_ACK, + REPGTO_CKP, + REPGTO_CONN, + REPGTO_ELECT, + REPGTO_ELECT_RETRY, + REPGTO_FULL, + REPGTO_HB_MON, + REPGTO_HB_SEND, + REPGTO_LEASE + }; + Tcl_Obj *res; + int optindex, result, ret, wh; + u_int32_t to; + + if (Tcl_GetIndexFromObj(interp, which, towhich, "option", + TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(which)); + + res = NULL; + switch ((enum towhich)optindex) { + case REPGTO_ACK: + wh = DB_REP_ACK_TIMEOUT; + break; + case REPGTO_CKP: + wh = DB_REP_CHECKPOINT_DELAY; + break; + case REPGTO_CONN: + wh = DB_REP_CONNECTION_RETRY; + break; + case REPGTO_ELECT: + wh = DB_REP_ELECTION_TIMEOUT; + break; + case REPGTO_ELECT_RETRY: + wh = DB_REP_ELECTION_RETRY; + break; + case REPGTO_FULL: + wh = DB_REP_FULL_ELECTION_TIMEOUT; + break; + case REPGTO_HB_MON: + wh = DB_REP_HEARTBEAT_MONITOR; + break; + case REPGTO_HB_SEND: + wh = DB_REP_HEARTBEAT_SEND; + break; + case REPGTO_LEASE: + wh = DB_REP_LEASE_TIMEOUT; + break; + default: + return (TCL_ERROR); + } + ret = dbenv->rep_get_timeout(dbenv, wh, &to); + if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_config")) == TCL_OK) { + res = Tcl_NewLongObj((long)to); + Tcl_SetObjResult(interp, res); + } + return (result); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepElect -- + * Call DB_ENV->rep_elect(). + * + * PUBLIC: int tcl_RepElect + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepElect(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 */ +{ + int result, ret; + u_int32_t full_timeout, nsites, nvotes, pri, timeout; + + if (objc != 6 && objc != 7) { + Tcl_WrongNumArgs(interp, 6, objv, + "nsites nvotes pri timeout [full_timeout]"); + return (TCL_ERROR); + } + + if ((result = _GetUInt32(interp, objv[2], &nsites)) != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[3], &nvotes)) != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[4], &pri)) != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[5], &timeout)) != TCL_OK) + return (result); + full_timeout = 0; + if (objc == 7) + if ((result = _GetUInt32(interp, objv[6], &full_timeout)) + != TCL_OK) + return (result); + + _debug_check(); + + if ((ret = dbenv->rep_set_priority(dbenv, pri)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_elect (rep_set_priority)")); + if ((ret = dbenv->rep_set_timeout(dbenv, DB_REP_ELECTION_TIMEOUT, + timeout)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_elect (rep_set_timeout)")); + + if (full_timeout != 0 && (ret = dbenv->rep_set_timeout(dbenv, + DB_REP_FULL_ELECTION_TIMEOUT, full_timeout)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_elect (rep_set_timeout)")); + + ret = dbenv->rep_elect(dbenv, nsites, nvotes, 0); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env rep_elect")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepFlush -- + * Call DB_ENV->rep_flush(). + * + * PUBLIC: int tcl_RepFlush + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepFlush(interp, objc, objv, dbenv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; + DB_ENV *dbenv; +{ + int ret; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + + _debug_check(); + ret = dbenv->rep_flush(dbenv); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env rep_flush")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepSync -- + * Call DB_ENV->rep_sync(). + * + * PUBLIC: int tcl_RepSync + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepSync(interp, objc, objv, dbenv) + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; + DB_ENV *dbenv; +{ + int ret; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + + _debug_check(); + ret = dbenv->rep_sync(dbenv, 0); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env rep_sync")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepLease -- + * Call DB_ENV->rep_set_lease(). + * + * PUBLIC: int tcl_RepLease __P((Tcl_Interp *, int, Tcl_Obj * CONST *, + * PUBLIC: DB_ENV *)); + */ +int +tcl_RepLease(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + u_int32_t clock_fast, clock_slow, nsites, timeout; + int result, ret; + + COMPQUIET(clock_fast, 0); + COMPQUIET(clock_slow, 0); + + if (objc != 4 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "{nsites timeout fast slow}"); + return (TCL_ERROR); + } + + if ((result = _GetUInt32(interp, objv[0], &nsites)) != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[1], &timeout)) != TCL_OK) + return (result); + if (objc == 4) { + if ((result = _GetUInt32(interp, objv[2], &clock_fast)) + != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[3], &clock_slow)) + != TCL_OK) + return (result); + } + ret = dbenv->rep_set_nsites(dbenv, nsites); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep_set_nsites"); + if (result != TCL_OK) + return (result); + ret = dbenv->rep_set_timeout(dbenv, DB_REP_LEASE_TIMEOUT, + (db_timeout_t)timeout); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep_set_timeout"); + ret = dbenv->rep_set_config(dbenv, DB_REP_CONF_LEASE, 1); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep_set_config"); + if (result != TCL_OK) + return (result); + if (objc == 4) + ret = dbenv->rep_set_clockskew(dbenv, clock_fast, clock_slow); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_set_lease")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepInmemFiles -- + * Set in-memory replication, which must be done before opening + * environment. + * + * PUBLIC: int tcl_RepInmemFiles __P((Tcl_Interp *, DB_ENV *)); + */ +int +tcl_RepInmemFiles(interp, dbenv) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; +{ + int ret; + + ret = dbenv->rep_set_config(dbenv, DB_REP_CONF_INMEM, 1); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep_set_config")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepLimit -- + * Call DB_ENV->rep_set_limit(). + * + * PUBLIC: int tcl_RepLimit + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepLimit(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 */ +{ + int result, ret; + u_int32_t bytes, gbytes; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 4, objv, "gbytes bytes"); + return (TCL_ERROR); + } + + if ((result = _GetUInt32(interp, objv[2], &gbytes)) != TCL_OK) + return (result); + if ((result = _GetUInt32(interp, objv[3], &bytes)) != TCL_OK) + return (result); + + _debug_check(); + if ((ret = dbenv->rep_set_limit(dbenv, gbytes, bytes)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env set_rep_limit")); + + return (_ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "env set_rep_limit")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepRequest -- + * Call DB_ENV->rep_set_request(). + * + * PUBLIC: int tcl_RepRequest + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepRequest(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 */ +{ + int result, ret; + long min, max; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 4, objv, "min max"); + return (TCL_ERROR); + } + + if ((result = Tcl_GetLongFromObj(interp, objv[2], &min)) != TCL_OK) + return (result); + if ((result = Tcl_GetLongFromObj(interp, objv[3], &max)) != TCL_OK) + return (result); + + _debug_check(); + if ((ret = dbenv->rep_set_request(dbenv, (db_timeout_t)min, + (db_timeout_t)max)) != 0) + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_request")); + + return (_ReturnSetup(interp, + ret, DB_RETOK_STD(ret), "env rep_request")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepNoarchiveTimeout -- + * Reset the master update timer, to allow immediate log archiving. + * + * PUBLIC: int tcl_RepNoarchiveTimeout + * PUBLIC: __P((Tcl_Interp *, DB_ENV *)); + */ +int +tcl_RepNoarchiveTimeout(interp, dbenv) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *dbenv; /* Environment pointer */ +{ + ENV *env; + REGENV *renv; + REGINFO *infop; + + env = dbenv->env; + + _debug_check(); + infop = env->reginfo; + renv = infop->primary; + REP_SYSTEM_LOCK(env); + F_CLR(renv, DB_REGENV_REPLOCKED); + renv->op_timestamp = 0; + REP_SYSTEM_UNLOCK(env); + + return (_ReturnSetup(interp, + 0, DB_RETOK_STD(0), "env test force noarchive_timeout")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepTransport -- + * Call DB_ENV->rep_set_transport(). + * + * PUBLIC: int tcl_RepTransport __P((Tcl_Interp *, int, Tcl_Obj * CONST *, + * PUBLIC: DB_ENV *, DBTCL_INFO *)); + * + * Note that this normally can/should be achieved as an argument to + * berkdb env, but we need to test changing the transport function on + * the fly. + */ +int +tcl_RepTransport(interp, objc, objv, dbenv, ip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; + DBTCL_INFO *ip; +{ + int intarg, result, ret; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "{id transport_func"); + return (TCL_ERROR); + } + + /* + * Store the objects containing the machine ID + * and the procedure name. We don't need to crack + * the send procedure out now, but we do convert the + * machine ID to an int, since rep_set_transport needs + * it. Even so, it'll be easier later to deal with + * the Tcl_Obj *, so we save that, not the int. + * + * Note that we Tcl_IncrRefCount both objects + * independently; Tcl is free to discard the list + * that they're bundled into. + */ + + /* + * Check that the machine ID is an int. Note that + * we do want to use GetIntFromObj; the machine + * ID is explicitly an int, not a u_int32_t. + */ + if (ip->i_rep_eid != NULL) { + Tcl_DecrRefCount(ip->i_rep_eid); + } + ip->i_rep_eid = objv[0]; + Tcl_IncrRefCount(ip->i_rep_eid); + result = Tcl_GetIntFromObj(interp, + ip->i_rep_eid, &intarg); + if (result != TCL_OK) + return (result); + + if (ip->i_rep_send != NULL) { + Tcl_DecrRefCount(ip->i_rep_send); + } + ip->i_rep_send = objv[1]; + Tcl_IncrRefCount(ip->i_rep_send); + _debug_check(); + ret = dbenv->rep_set_transport(dbenv, intarg, tcl_rep_send); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "env rep_transport")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepStart -- + * Call DB_ENV->rep_start(). + * + * PUBLIC: int tcl_RepStart + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + * + * Note that this normally can/should be achieved as an argument to + * berkdb env, but we need to test forcible upgrading of clients, which + * involves calling this on an open environment handle. + */ +int +tcl_RepStart(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + static const char *tclrpstrt[] = { + "-client", + "-master", + NULL + }; + enum tclrpstrt { + TCL_RPSTRT_CLIENT, + TCL_RPSTRT_MASTER + }; + char *arg; + int i, optindex, ret; + u_int32_t flag; + + flag = 0; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "[-master/-client]"); + return (TCL_ERROR); + } + + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], tclrpstrt, + "option", TCL_EXACT, &optindex) != TCL_OK) { + arg = Tcl_GetStringFromObj(objv[i], NULL); + if (arg[0] == '-') + return (IS_HELP(objv[i])); + else + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum tclrpstrt)optindex) { + case TCL_RPSTRT_CLIENT: + flag = DB_REP_CLIENT; + break; + case TCL_RPSTRT_MASTER: + flag = DB_REP_MASTER; + break; + } + } + + _debug_check(); + ret = dbenv->rep_start(dbenv, NULL, flag); + return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env rep_start")); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepProcessMessage -- + * Call DB_ENV->rep_process_message(). + * + * PUBLIC: int tcl_RepProcessMessage + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepProcessMessage(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 */ +{ + DBT control, rec; + DB_LSN permlsn; + Tcl_Obj *lsnlist, *myobjv[2], *res; + void *ctmp, *rtmp; + char *msg; + int eid; + int freectl, freerec, myobjc, result, ret; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 5, objv, "id control rec"); + return (TCL_ERROR); + } + freectl = freerec = 0; + + memset(&control, 0, sizeof(control)); + memset(&rec, 0, sizeof(rec)); + + if ((result = Tcl_GetIntFromObj(interp, objv[2], &eid)) != TCL_OK) + return (result); + + ret = _CopyObjBytes(interp, objv[3], &ctmp, + &control.size, &freectl); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_REPPMSG(ret), "rep_proc_msg"); + return (result); + } + control.data = ctmp; + ret = _CopyObjBytes(interp, objv[4], &rtmp, + &rec.size, &freerec); + if (ret != 0) { + result = _ReturnSetup(interp, ret, + DB_RETOK_REPPMSG(ret), "rep_proc_msg"); + goto out; + } + rec.data = rtmp; + _debug_check(); + ret = dbenv->rep_process_message(dbenv, &control, &rec, eid, &permlsn); + /* + * !!! + * The TCL API diverges from the C++/Java APIs here. For us, it + * is OK to get DUPMASTER and HOLDELECTION for testing purposes. + */ + result = _ReturnSetup(interp, ret, + DB_RETOK_REPPMSG(ret) || ret == DB_REP_DUPMASTER || + ret == DB_REP_HOLDELECTION, + "env rep_process_message"); + + if (result != TCL_OK) + goto out; + + /* + * We have a valid return. We need to return a variety of information. + * It will be one of the following: + * {0 0} - Make a 0 return a list for consistent return structure. + * {DUPMASTER 0} - DUPMASTER, no other info needed. + * {HOLDELECTION 0} - HOLDELECTION, no other info needed. + * {NEWMASTER #} - NEWMASTER and its ID. + * {NEWSITE 0} - NEWSITE, no other info needed. + * {IGNORE {LSN list}} - IGNORE and this msg's LSN. + * {ISPERM {LSN list}} - ISPERM and the perm LSN. + * {NOTPERM {LSN list}} - NOTPERM and this msg's LSN. + */ + myobjc = 2; + switch (ret) { + case 0: + myobjv[0] = Tcl_NewIntObj(0); + myobjv[1] = Tcl_NewIntObj(0); + break; + case DB_REP_DUPMASTER: + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"DUPMASTER", (int)strlen("DUPMASTER")); + myobjv[1] = Tcl_NewIntObj(0); + break; + case DB_REP_HOLDELECTION: + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"HOLDELECTION", (int)strlen("HOLDELECTION")); + myobjv[1] = Tcl_NewIntObj(0); + break; + case DB_REP_IGNORE: + myobjv[0] = Tcl_NewLongObj((long)permlsn.file); + myobjv[1] = Tcl_NewLongObj((long)permlsn.offset); + lsnlist = Tcl_NewListObj(myobjc, myobjv); + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"IGNORE", (int)strlen("IGNORE")); + myobjv[1] = lsnlist; + break; + case DB_REP_ISPERM: + myobjv[0] = Tcl_NewLongObj((long)permlsn.file); + myobjv[1] = Tcl_NewLongObj((long)permlsn.offset); + lsnlist = Tcl_NewListObj(myobjc, myobjv); + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"ISPERM", (int)strlen("ISPERM")); + myobjv[1] = lsnlist; + break; + case DB_REP_NEWSITE: + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"NEWSITE", (int)strlen("NEWSITE")); + myobjv[1] = Tcl_NewIntObj(0); + break; + case DB_REP_NOTPERM: + myobjv[0] = Tcl_NewLongObj((long)permlsn.file); + myobjv[1] = Tcl_NewLongObj((long)permlsn.offset); + lsnlist = Tcl_NewListObj(myobjc, myobjv); + myobjv[0] = Tcl_NewByteArrayObj( + (u_char *)"NOTPERM", (int)strlen("NOTPERM")); + myobjv[1] = lsnlist; + break; + default: + msg = db_strerror(ret); + Tcl_AppendResult(interp, msg, NULL); + Tcl_SetErrorCode(interp, "BerkeleyDB", msg, NULL); + result = TCL_ERROR; + goto out; + } + res = Tcl_NewListObj(myobjc, myobjv); + if (res != NULL) + Tcl_SetObjResult(interp, res); +out: + if (freectl) + __os_free(NULL, ctmp); + if (freerec) + __os_free(NULL, rtmp); + + return (result); +} +#endif + +#ifdef CONFIG_TEST +/* + * tcl_RepStat -- + * Call DB_ENV->rep_stat(). + * + * PUBLIC: int tcl_RepStat + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepStat(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + DB_REP_STAT *sp; + Tcl_Obj *myobjv[2], *res, *thislist, *lsnlist; + u_int32_t flag; + int myobjc, result, ret; + char *arg, *role; + + flag = 0; + result = TCL_OK; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + 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 = dbenv->rep_stat(dbenv, &sp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep 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_* assumes 'res' and 'error' label. + */ + if (sp->st_status == DB_REP_MASTER) + role = "master"; + else if (sp->st_status == DB_REP_CLIENT) + role = "client"; + else + role = "none"; + MAKE_STAT_STRLIST("Role", role); + + MAKE_STAT_LSN("Next LSN expected", &sp->st_next_lsn); + MAKE_STAT_LSN("First missed LSN", &sp->st_waiting_lsn); + MAKE_STAT_LSN("Maximum permanent LSN", &sp->st_max_perm_lsn); + MAKE_WSTAT_LIST("Bulk buffer fills", sp->st_bulk_fills); + MAKE_WSTAT_LIST("Bulk buffer overflows", sp->st_bulk_overflows); + MAKE_WSTAT_LIST("Bulk records stored", sp->st_bulk_records); + MAKE_WSTAT_LIST("Bulk buffer transfers", sp->st_bulk_transfers); + MAKE_WSTAT_LIST("Client service requests", sp->st_client_svc_req); + MAKE_WSTAT_LIST("Client service req misses", sp->st_client_svc_miss); + MAKE_WSTAT_LIST("Client rerequests", sp->st_client_rerequests); + MAKE_STAT_LIST("Duplicate master conditions", sp->st_dupmasters); + MAKE_STAT_LIST("Environment ID", sp->st_env_id); + MAKE_STAT_LIST("Environment priority", sp->st_env_priority); + MAKE_STAT_LIST("Generation number", sp->st_gen); + MAKE_STAT_LIST("Election generation number", sp->st_egen); + MAKE_STAT_LIST("Startup complete", sp->st_startup_complete); + MAKE_WSTAT_LIST("Duplicate log records received", sp->st_log_duplicated); + MAKE_WSTAT_LIST("Current log records queued", sp->st_log_queued); + MAKE_WSTAT_LIST("Maximum log records queued", sp->st_log_queued_max); + MAKE_WSTAT_LIST("Total log records queued", sp->st_log_queued_total); + MAKE_WSTAT_LIST("Log records received", sp->st_log_records); + MAKE_WSTAT_LIST("Log records requested", sp->st_log_requested); + MAKE_STAT_LIST("Master environment ID", sp->st_master); + MAKE_WSTAT_LIST("Master changes", sp->st_master_changes); + MAKE_STAT_LIST("Messages with bad generation number", + sp->st_msgs_badgen); + MAKE_WSTAT_LIST("Messages processed", sp->st_msgs_processed); + MAKE_WSTAT_LIST("Messages ignored for recovery", sp->st_msgs_recover); + MAKE_WSTAT_LIST("Message send failures", sp->st_msgs_send_failures); + MAKE_WSTAT_LIST("Messages sent", sp->st_msgs_sent); + MAKE_WSTAT_LIST("New site messages", sp->st_newsites); + MAKE_STAT_LIST("Number of sites in replication group", sp->st_nsites); + MAKE_WSTAT_LIST("Transmission limited", sp->st_nthrottles); + MAKE_WSTAT_LIST("Outdated conditions", sp->st_outdated); + MAKE_WSTAT_LIST("Transactions applied", sp->st_txns_applied); + MAKE_STAT_LIST("Next page expected", sp->st_next_pg); + MAKE_WSTAT_LIST("First missed page", sp->st_waiting_pg); + MAKE_WSTAT_LIST("Duplicate pages received", sp->st_pg_duplicated); + MAKE_WSTAT_LIST("Pages received", sp->st_pg_records); + MAKE_WSTAT_LIST("Pages requested", sp->st_pg_requested); + MAKE_WSTAT_LIST("Elections held", sp->st_elections); + MAKE_WSTAT_LIST("Elections won", sp->st_elections_won); + MAKE_STAT_LIST("Election phase", sp->st_election_status); + MAKE_STAT_LIST("Election winner", sp->st_election_cur_winner); + MAKE_STAT_LIST("Election generation number", sp->st_election_gen); + MAKE_STAT_LSN("Election max LSN", &sp->st_election_lsn); + MAKE_STAT_LIST("Election sites", sp->st_election_nsites); + MAKE_STAT_LIST("Election nvotes", sp->st_election_nvotes); + MAKE_STAT_LIST("Election priority", sp->st_election_priority); + MAKE_STAT_LIST("Election tiebreaker", sp->st_election_tiebreaker); + MAKE_STAT_LIST("Election votes", sp->st_election_votes); + MAKE_STAT_LIST("Election seconds", sp->st_election_sec); + MAKE_STAT_LIST("Election usecs", sp->st_election_usec); + MAKE_STAT_LIST("Start-sync operations delayed", + sp->st_startsync_delayed); + MAKE_STAT_LIST("Maximum lease seconds", sp->st_max_lease_sec); + MAKE_STAT_LIST("Maximum lease usecs", sp->st_max_lease_usec); + MAKE_STAT_LIST("File fail cleanups done", sp->st_filefail_cleanups); +#endif + + Tcl_SetObjResult(interp, res); +error: + __os_ufree(dbenv->env, sp); + return (result); +} + +/* + * tcl_RepMgr -- + * Configure and start the Replication Manager. + * + * PUBLIC: int tcl_RepMgr + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepMgr(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 *rmgr[] = { + "-ack", + "-local", + "-msgth", + "-nsites", + "-pri", + "-remote", + "-start", + "-timeout", + NULL + }; + enum rmgr { + RMGR_ACK, + RMGR_LOCAL, + RMGR_MSGTH, + RMGR_NSITES, + RMGR_PRI, + RMGR_REMOTE, + RMGR_START, + RMGR_TIMEOUT + }; + Tcl_Obj **myobjv; + long to; + int ack, i, myobjc, optindex, result, ret, totype; + u_int32_t msgth, remote_flag, start_flag, uintarg; + char *arg; + + result = TCL_OK; + ack = ret = totype = 0; + msgth = 1; + remote_flag = start_flag = 0; + + if (objc <= 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?args?"); + return (TCL_ERROR); + } + /* + * Get the command name index from the object based on the bdbcmds + * defined above. + */ + i = 2; + while (i < objc) { + Tcl_ResetResult(interp); + if (Tcl_GetIndexFromObj(interp, objv[i], rmgr, "option", + TCL_EXACT, &optindex) != TCL_OK) { + result = IS_HELP(objv[i]); + goto error; + } + i++; + switch ((enum rmgr)optindex) { + case RMGR_ACK: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-ack policy?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(arg, "all") == 0) + ack = DB_REPMGR_ACKS_ALL; + else if (strcmp(arg, "allpeers") == 0) + ack = DB_REPMGR_ACKS_ALL_PEERS; + else if (strcmp(arg, "none") == 0) + ack = DB_REPMGR_ACKS_NONE; + else if (strcmp(arg, "one") == 0) + ack = DB_REPMGR_ACKS_ONE; + else if (strcmp(arg, "onepeer") == 0) + ack = DB_REPMGR_ACKS_ONE_PEER; + else if (strcmp(arg, "quorum") == 0) + ack = DB_REPMGR_ACKS_QUORUM; + else { + Tcl_AddErrorInfo(interp, + "ack: illegal policy"); + result = TCL_ERROR; + break; + } + _debug_check(); + ret = dbenv->repmgr_set_ack_policy(dbenv, ack); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "ack"); + break; + case RMGR_LOCAL: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-local {host port}?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(myobjv[0], NULL); + if ((result = _GetUInt32(interp, myobjv[1], &uintarg)) + != TCL_OK) + break; + _debug_check(); + /* + * No flags for now. + */ + ret = dbenv->repmgr_set_local_site(dbenv, + arg, uintarg, 0); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "repmgr_set_local_site"); + break; + case RMGR_MSGTH: + if (i >= objc) { + Tcl_WrongNumArgs( + interp, 2, objv, "?-msgth nth?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &msgth); + break; + case RMGR_NSITES: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-nsites num_sites?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv-> + rep_set_nsites(dbenv, uintarg); + } + break; + case RMGR_PRI: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-pri priority?"); + result = TCL_ERROR; + break; + } + result = _GetUInt32(interp, objv[i++], &uintarg); + if (result == TCL_OK) { + _debug_check(); + ret = dbenv-> + rep_set_priority(dbenv, uintarg); + } + break; + case RMGR_REMOTE: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2 && myobjc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-remote {host port [peer]}?"); + result = TCL_ERROR; + break; + } + /* + * Get the flag first so we can reuse 'arg'. + */ + if (myobjc == 3) { + arg = Tcl_GetStringFromObj(myobjv[2], NULL); + if (strcmp(arg, "peer") == 0) + remote_flag = DB_REPMGR_PEER; + else { + Tcl_AddErrorInfo(interp, + "remote: illegal flag"); + result = TCL_ERROR; + break; + } + } + arg = Tcl_GetStringFromObj(myobjv[0], NULL); + if ((result = _GetUInt32(interp, myobjv[1], &uintarg)) + != TCL_OK) + break; + _debug_check(); + ret = dbenv->repmgr_add_remote_site(dbenv, + arg, uintarg, NULL, remote_flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "repmgr_add_remote_site"); + break; + case RMGR_START: + if (i >= objc) { + Tcl_WrongNumArgs( + interp, 2, objv, "?-start state?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + if (strcmp(arg, "master") == 0) + start_flag = DB_REP_MASTER; + else if (strcmp(arg, "client") == 0) + start_flag = DB_REP_CLIENT; + else if (strcmp(arg, "elect") == 0) + start_flag = DB_REP_ELECTION; + else { + Tcl_AddErrorInfo( + interp, "start: illegal state"); + result = TCL_ERROR; + break; + } + /* + * Some config functions need to be called + * before repmgr_start. So finish parsing all + * the args and call repmgr_start at the end. + */ + break; + case RMGR_TIMEOUT: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + if (myobjc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-timeout {type to}?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(myobjv[0], NULL); + if (strcmp(arg, "ack") == 0) + totype = DB_REP_ACK_TIMEOUT; + else if (strcmp(arg, "conn_retry") == 0) + totype = DB_REP_CONNECTION_RETRY; + else if (strcmp(arg, "elect") == 0) + totype = DB_REP_ELECTION_TIMEOUT; + else if (strcmp(arg, "elect_retry") == 0) + totype = DB_REP_ELECTION_RETRY; + else if (strcmp(arg, "heartbeat_monitor") == 0) + totype = DB_REP_HEARTBEAT_MONITOR; + else if (strcmp(arg, "heartbeat_send") == 0) + totype = DB_REP_HEARTBEAT_SEND; + else { + Tcl_AddErrorInfo(interp, + "timeout: illegal type"); + result = TCL_ERROR; + break; + } + if ((result = Tcl_GetLongFromObj( + interp, myobjv[1], &to)) != TCL_OK) + break; + _debug_check(); + ret = dbenv->rep_set_timeout(dbenv, totype, + (db_timeout_t)to); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "rep_set_timeout"); + break; + } + /* + * If, at any time, parsing the args we get an error, + * bail out and return. + */ + if (result != TCL_OK) + goto error; + } + /* + * Only call repmgr_start if needed. The user may use this + * call just to reconfigure, change policy, etc. + */ + if (start_flag != 0 && result == TCL_OK) { + _debug_check(); + ret = dbenv->repmgr_start(dbenv, (int)msgth, start_flag); + result = _ReturnSetup( + interp, ret, DB_RETOK_REPMGR_START(ret), "repmgr_start"); + } +error: + return (result); +} + +/* + * tcl_RepMgrSiteList -- + * Call DB_ENV->repmgr_site_list(). + * + * PUBLIC: int tcl_RepMgrSiteList + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepMgrSiteList(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + DB_REPMGR_SITE *sp; + Tcl_Obj *myobjv[4], *res, *thislist; + u_int count, i; + char *st; + int myobjc, result, ret; + + result = TCL_OK; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + + _debug_check(); + ret = dbenv->repmgr_site_list(dbenv, &count, &sp); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "repmgr sitelist"); + if (result == TCL_ERROR) + return (result); + + /* + * Have our sites, now construct the {eid host port status} + * tuples and free up the memory. + */ + res = Tcl_NewObj(); + + for (i = 0; i < count; ++i) { + /* + * MAKE_SITE_LIST assumes 'res' and 'error' label. + */ + if (sp[i].status == DB_REPMGR_CONNECTED) + st = "connected"; + else if (sp[i].status == DB_REPMGR_DISCONNECTED) + st = "disconnected"; + else + st = "unknown"; + MAKE_SITE_LIST(sp[i].eid, sp[i].host, sp[i].port, st); + } + + Tcl_SetObjResult(interp, res); +error: + __os_ufree(dbenv->env, sp); + return (result); +} + +/* + * tcl_RepMgrStat -- + * Call DB_ENV->repmgr_stat(). + * + * PUBLIC: int tcl_RepMgrStat + * PUBLIC: __P((Tcl_Interp *, int, Tcl_Obj * CONST *, DB_ENV *)); + */ +int +tcl_RepMgrStat(interp, objc, objv, dbenv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *dbenv; +{ + DB_REPMGR_STAT *sp; + Tcl_Obj *res; + u_int32_t flag; + int result, ret; + char *arg; + + flag = 0; + result = TCL_OK; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + 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 = dbenv->repmgr_stat(dbenv, &sp, flag); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), + "repmgr 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_* assumes 'res' and 'error' label. + */ + MAKE_WSTAT_LIST("Acknowledgement failures", sp->st_perm_failed); + MAKE_WSTAT_LIST("Messages delayed", sp->st_msgs_queued); + MAKE_WSTAT_LIST("Messages discarded", sp->st_msgs_dropped); + MAKE_WSTAT_LIST("Connections dropped", sp->st_connection_drop); + MAKE_WSTAT_LIST("Failed re-connects", sp->st_connect_fail); +#endif + + Tcl_SetObjResult(interp, res); +error: + __os_ufree(dbenv->env, sp); + return (result); +} +#endif diff --git a/tcl/tcl_seq.c b/tcl/tcl_seq.c new file mode 100644 index 0000000..dc35e22 --- /dev/null +++ b/tcl/tcl_seq.c @@ -0,0 +1,511 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 2004-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_WSTAT_LIST("Wait", sp->st_wait); + MAKE_WSTAT_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 */ diff --git a/tcl/tcl_txn.c b/tcl/tcl_txn.c new file mode 100644 index 0000000..850ff02 --- /dev/null +++ b/tcl/tcl_txn.c @@ -0,0 +1,778 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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_WSTAT_LIST("Number aborted txns", sp->st_naborts); + MAKE_WSTAT_LIST("Number txns begun", sp->st_nbegins); + MAKE_WSTAT_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_WSTAT_LIST("Number of region lock waits", sp->st_region_wait); + MAKE_WSTAT_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_GID_SIZE]; + 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, \ + (u_int32_t)strlen(newname), p->gid, DB_GID_SIZE); \ + if (result != TCL_OK) \ + goto error; \ +} + + DBTCL_INFO *ip; + DB_PREPLIST prep[DBTCL_PREP], *p; + Tcl_Obj *res; + u_int32_t 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 diff --git a/tcl/tcl_util.c b/tcl/tcl_util.c new file mode 100644 index 0000000..addf56a --- /dev/null +++ b/tcl/tcl_util.c @@ -0,0 +1,121 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999-2009 Oracle. All rights reserved. + * + * $Id$ + */ + +#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); + } +#ifdef HAVE_RANDOM + ret = random(); +#else + ret = rand(); +#endif + 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(); +#ifdef HAVE_RANDOM + ret = lo + random() % ((hi - lo) + 1); +#else + ret = lo + rand() % ((hi - lo) + 1); +#endif + 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) { +#ifdef HAVE_RANDOM + srandom((u_int)lo); +#else + srand((u_int)lo); +#endif + 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); +} |