diff options
| author | Zhang Qiang <qiang.z.zhang@intel.com> | 2012-05-29 11:25:24 +0800 |
|---|---|---|
| committer | Zhang Qiang <qiang.z.zhang@intel.com> | 2012-05-29 11:25:24 +0800 |
| commit | e776056ea09ba0b6d9505ced6913c9190a12d632 (patch) | |
| tree | 092838f2a86042abc586aa5576e36ae6cb47e256 /tcl | |
| parent | 2e082c838d2ca750f5daac6dcdabecc22dfd4e46 (diff) | |
| download | db4-e776056ea09ba0b6d9505ced6913c9190a12d632.tar.gz db4-e776056ea09ba0b6d9505ced6913c9190a12d632.tar.bz2 db4-e776056ea09ba0b6d9505ced6913c9190a12d632.zip | |
updated with Tizen:Base source codes
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, 0 insertions, 20467 deletions
diff --git a/tcl/docs/db.html b/tcl/docs/db.html deleted file mode 100644 index 02429af..0000000 --- a/tcl/docs/db.html +++ /dev/null @@ -1,267 +0,0 @@ -<!--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 deleted file mode 100644 index eba6fb1..0000000 --- a/tcl/docs/env.html +++ /dev/null @@ -1,344 +0,0 @@ -<!--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 deleted file mode 100644 index 97e33e6..0000000 --- a/tcl/docs/historic.html +++ /dev/null @@ -1,168 +0,0 @@ -<!--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 deleted file mode 100644 index ae35bd6..0000000 --- a/tcl/docs/index.html +++ /dev/null @@ -1,50 +0,0 @@ -<!--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 deleted file mode 100644 index a56898e..0000000 --- a/tcl/docs/library.html +++ /dev/null @@ -1,26 +0,0 @@ -<!--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 deleted file mode 100644 index abd15c2..0000000 --- a/tcl/docs/lock.html +++ /dev/null @@ -1,206 +0,0 @@ -<!--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 deleted file mode 100644 index 02cd399..0000000 --- a/tcl/docs/log.html +++ /dev/null @@ -1,123 +0,0 @@ -<!--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 deleted file mode 100644 index 25967e3..0000000 --- a/tcl/docs/mpool.html +++ /dev/null @@ -1,189 +0,0 @@ -<!--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 deleted file mode 100644 index 3c1e49c..0000000 --- a/tcl/docs/rep.html +++ /dev/null @@ -1,50 +0,0 @@ -<!--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 deleted file mode 100644 index 4aceab8..0000000 --- a/tcl/docs/sequence.html +++ /dev/null @@ -1,93 +0,0 @@ -<!--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 deleted file mode 100644 index 225f6a2..0000000 --- a/tcl/docs/test.html +++ /dev/null @@ -1,103 +0,0 @@ -<!--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 deleted file mode 100644 index 3f234a2..0000000 --- a/tcl/docs/txn.html +++ /dev/null @@ -1,69 +0,0 @@ -<!--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 deleted file mode 100644 index 6b3664d..0000000 --- a/tcl/tcl_compat.c +++ /dev/null @@ -1,738 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 4b68cd9..0000000 --- a/tcl/tcl_db.c +++ /dev/null @@ -1,3465 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 76543f4..0000000 --- a/tcl/tcl_db_pkg.c +++ /dev/null @@ -1,4398 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 9b943ba..0000000 --- a/tcl/tcl_dbcursor.c +++ /dev/null @@ -1,1056 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 15d7b70..0000000 --- a/tcl/tcl_env.c +++ /dev/null @@ -1,2670 +0,0 @@ -/*- - * 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 deleted file mode 100644 index d5a3e99..0000000 --- a/tcl/tcl_internal.c +++ /dev/null @@ -1,817 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 03b1bed..0000000 --- a/tcl/tcl_lock.c +++ /dev/null @@ -1,775 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 3b77208..0000000 --- a/tcl/tcl_log.c +++ /dev/null @@ -1,770 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 5c6488f..0000000 --- a/tcl/tcl_mp.c +++ /dev/null @@ -1,939 +0,0 @@ -/*- - * 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 deleted file mode 100644 index c05b208..0000000 --- a/tcl/tcl_mutex.c +++ /dev/null @@ -1,315 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 37619fd..0000000 --- a/tcl/tcl_rep.c +++ /dev/null @@ -1,1426 +0,0 @@ -/*- - * 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 deleted file mode 100644 index dc35e22..0000000 --- a/tcl/tcl_seq.c +++ /dev/null @@ -1,511 +0,0 @@ -/*- - * 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 deleted file mode 100644 index 850ff02..0000000 --- a/tcl/tcl_txn.c +++ /dev/null @@ -1,778 +0,0 @@ -/*- - * 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 deleted file mode 100644 index addf56a..0000000 --- a/tcl/tcl_util.c +++ /dev/null @@ -1,121 +0,0 @@ -/*- - * 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); -} |