diff options
Diffstat (limited to 'bdb/tcl')
| -rw-r--r-- | bdb/tcl/docs/db.html | 263 | ||||
| -rw-r--r-- | bdb/tcl/docs/env.html | 354 | ||||
| -rw-r--r-- | bdb/tcl/docs/historic.html | 169 | ||||
| -rw-r--r-- | bdb/tcl/docs/index.html | 51 | ||||
| -rw-r--r-- | bdb/tcl/docs/library.html | 27 | ||||
| -rw-r--r-- | bdb/tcl/docs/lock.html | 207 | ||||
| -rw-r--r-- | bdb/tcl/docs/log.html | 124 | ||||
| -rw-r--r-- | bdb/tcl/docs/mpool.html | 190 | ||||
| -rw-r--r-- | bdb/tcl/docs/rep.html | 51 | ||||
| -rw-r--r-- | bdb/tcl/docs/test.html | 150 | ||||
| -rw-r--r-- | bdb/tcl/docs/txn.html | 67 | ||||
| -rw-r--r-- | bdb/tcl/tcl_compat.c | 746 | ||||
| -rw-r--r-- | bdb/tcl/tcl_db.c | 2421 | ||||
| -rw-r--r-- | bdb/tcl/tcl_db_pkg.c | 3117 | ||||
| -rw-r--r-- | bdb/tcl/tcl_dbcursor.c | 924 | ||||
| -rw-r--r-- | bdb/tcl/tcl_env.c | 1310 | ||||
| -rw-r--r-- | bdb/tcl/tcl_internal.c | 717 | ||||
| -rw-r--r-- | bdb/tcl/tcl_lock.c | 739 | ||||
| -rw-r--r-- | bdb/tcl/tcl_log.c | 610 | ||||
| -rw-r--r-- | bdb/tcl/tcl_mp.c | 864 | ||||
| -rw-r--r-- | bdb/tcl/tcl_rep.c | 405 | ||||
| -rw-r--r-- | bdb/tcl/tcl_txn.c | 657 | ||||
| -rw-r--r-- | bdb/tcl/tcl_util.c | 381 |
23 files changed, 0 insertions, 14544 deletions
diff --git a/bdb/tcl/docs/db.html b/bdb/tcl/docs/db.html deleted file mode 100644 index 4f04c2c4f96..00000000000 --- a/bdb/tcl/docs/db.html +++ /dev/null @@ -1,263 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--All rights reserved.--> -<HTML> -<HEAD> - <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1"> - <META NAME="GENERATOR" CONTENT="Mozilla/4.08 [en] (X11; I; FreeBSD 3.3-RELEASE i386) [Netscape]"> -</HEAD> -<BODY> - -<H2> -<A NAME="Database Commands"></A>Database Commands</H2> -The database commands provide a fairly straightforward mapping to the -DB method functions. - -<P> -<B>> berkdb open</B> -<dl> - -<dt><B>[-btcompare <I>proc</I>]</B><dd> -Sets the Btree comparison function to the Tcl procedure named -<I>proc</I> using the -<A HREF="../../docs/api_c/db_set_bt_compare.html">DB->set_bt_compare</A> -method. - -<dt><B>[-btree|-hash|-recno|-queue|-unknown]</B><dd> -</td><td> -Select the database type:<br> -DB_BTREE, DB_HASH, DB_RECNO, DB_QUEUE or DB_UNKNOWN. - - -<dt><B>[-cachesize {<I>gbytes bytes ncaches</I>}]</B><dd> -Sets the size of the database cache to the size specified by -<I>gbytes</I> and <I>bytes</I>, broken up into <I>ncaches</I> number of -caches using the -<A HREF="../../docs/api_c/db_set_cachesize.html">DB->set_cachesize</A> -method. - -<dt><B>[-create]</B><dd> -Selects the DB_CREATE flag to create underlying files. - -<dt><B>[-delim <I>delim</I>]</B><dd> -Sets the delimiting byte for variable length records to <I>delim</I> -using the -<A HREF="../../docs/api_c/db_set_re_delim.html">DB->set_re_delim</A> -method. - -<dt><B>[-dup]</B><dd> -Selects the DB_DUP flag to permit duplicates in the database. - -<dt><B>[-dupcompare <I>proc</I>]</B><dd> -Sets the duplicate data comparison function to the Tcl procedure named -<I>proc</I> using the -<A HREF="../../docs/api_c/db_set_dup_compare.html">DB->set_dup_compare</A> -method. - -<dt><B>[-dupsort]</B><dd> -Selects the DB_DUPSORT flag to support sorted duplicates. - -<dt><B>[-env <I>env</I>]</B><dd> -The database environment. - -<dt><B>[-errfile <I>filename</I>]</B><dd> -Specifies the error file to use for this environment to <I>filename</I> -by calling -<A HREF="../../docs/api_c/db_set_errfile.html">DB->set_errfile</A>. -If the file already exists then we will append to the end of the file. - -<dt><B>[-excl]</B><dd> -Selects the DB_EXCL flag to exclusively create underlying files. - -<dt><B>[-extent <I>size</I>]</B><dd> -Sets the size of a Queue database extent to the given <I>size</I> using -the -<A HREF="../../docs/api_c/db_set_q_extentsize.html">DB->set_q_extentsize</A> -method. - -<dt><B>[-ffactor <I>density</I>]</B><dd> -Sets the hash table key density to the given <I>density</I> using the -<A HREF="../../docs/api_c/db_set_h_ffactor.html">DB->set_h_ffactor</A> -method. - -<dt><B>[-hashproc <I>proc</I>]</B><dd> -Sets a user-defined hash function to the Tcl procedure named <I>proc</I> -using the -<A HREF="../../docs/api_c/db_set_h_hash.html">DB->set_h_hash</A> method. - -<dt><B>[-len <I>len</I>]</B><dd> -Sets the length of fixed-length records to <I>len</I> using the -<A HREF="../../docs/api_c/db_set_re_len.html">DB->set_re_len</A> -method. - -<dt><B>[-lorder <I>order</I>]</B><dd> -Sets the byte order for integers stored in the database meta-data to -the given <I>order</I> using the -<A HREF="../../docs/api_c/db_set_lorder.html">DB->set_lorder</A> -method. - -<dt><B>[-minkey <I>minkey</I>]</B><dd> -Sets the minimum number of keys per Btree page to <I>minkey</I> using -the -<A HREF="../../docs/api_c/db_set_bt_minkey.html">DB->set_bt_minkey</A> -method. - -<dt><B>[-mode <I>mode</I>]</B><dd> -Specifies the mode for created files. - -<dt><B>[-nelem <I>size</I>]</B><dd> -Sets the hash table size estimate to the given <I>size</I> using the -<A HREF="../../docs/api_c/db_set_h_nelem.html">DB->set_h_nelem</A> -method. - -<dt><B>[-nommap]</B><dd> -Selects the DB_NOMMAP flag to forbid mmaping of files. - -<dt><B>[-pad <I>pad</I>]</B><dd> -Sets the pad character used for fixed length records to <I>pad</I> using -the -<A HREF="../../docs/db_set_re_pad.html">DB->set_re_pad</A> method. - -<dt><B>[-pagesize <I>pagesize</I>]</B><dd> -Sets the size of the database page to <I>pagesize</I> using the -<A HREF="../../docs/api_c/db_set_pagesize.html">DB->set_pagesize</A> -method. - -<dt><B>[-rdonly]</B><dd> -Selects the DB_RDONLY flag for opening in read-only mode. - -<dt><B>[-recnum]</B><dd> -Selects the DB_RECNUM flag to support record numbers in Btrees. - -<dt><B>[-renumber]</B><dd> -Selects the DB_RENUMBER flag to support mutable record numbers. - -<dt><B>[-revsplitoff]</B><dd> -Selects the DB_REVSPLITOFF flag to suppress reverse splitting of pages -on deletion. - -<dt><B>[-snapshot]</B><dd> -Selects the DB_SNAPSHOT flag to support database snapshots. - -<dt><B>[-source <I>file</I>]</B><dd> -Sets the backing source file name to <I>file</I> using the -<A HREF="../../docs/api_c/db_set_re_source.html">DB->set_re_source</A> -method. - -<dt><B>[-truncate]</B><dd> -Selects the DB_TRUNCATE flag to truncate the database. - -<dt><B>[--]</B><dd> -Terminate the list of options and use remaining arguments as the file -or subdb names (thus allowing the use of filenames beginning with a dash -'-'). - -<dt><B>[<I>filename </I>[<I>subdbname</I>]]</B><dd> -The names of the database and sub-database. -</dl> - -<HR WIDTH="100%"> -<B>> berkdb upgrade [-dupsort] [-env <I>env</I>] [--] [<I>filename</I>]</B> -<P>This command will invoke the <A HREF="../../docs/api_c/db_upgrade.html">DB->upgrade</A> -function. 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/bdb/tcl/docs/env.html b/bdb/tcl/docs/env.html deleted file mode 100644 index 79c349841ac..00000000000 --- a/bdb/tcl/docs/env.html +++ /dev/null @@ -1,354 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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 </b>sets the maximum size of the lock table to <b><i>max </i></b>using -the <a href="../../docs/api_c/env_set_lk_max.html">DBENV->set_lk_max</a> -method call</li> - -<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->set_rep_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>chkpt</b> - Chooses the checkpointing code by using the DB_VERB_CHKPOINT -value</li> - -<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/bdb/tcl/docs/historic.html b/bdb/tcl/docs/historic.html deleted file mode 100644 index 85f474fbc0f..00000000000 --- a/bdb/tcl/docs/historic.html +++ /dev/null @@ -1,169 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/index.html b/bdb/tcl/docs/index.html deleted file mode 100644 index 845b6ca81e2..00000000000 --- a/bdb/tcl/docs/index.html +++ /dev/null @@ -1,51 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/library.html b/bdb/tcl/docs/library.html deleted file mode 100644 index bfb1588c3f2..00000000000 --- a/bdb/tcl/docs/library.html +++ /dev/null @@ -1,27 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/lock.html b/bdb/tcl/docs/lock.html deleted file mode 100644 index d65142b798b..00000000000 --- a/bdb/tcl/docs/lock.html +++ /dev/null @@ -1,207 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/log.html b/bdb/tcl/docs/log.html deleted file mode 100644 index 49f2f0ad2e0..00000000000 --- a/bdb/tcl/docs/log.html +++ /dev/null @@ -1,124 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/mpool.html b/bdb/tcl/docs/mpool.html deleted file mode 100644 index 7f2359b36e9..00000000000 --- a/bdb/tcl/docs/mpool.html +++ /dev/null @@ -1,190 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/rep.html b/bdb/tcl/docs/rep.html deleted file mode 100644 index 079fe443a63..00000000000 --- a/bdb/tcl/docs/rep.html +++ /dev/null @@ -1,51 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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/bdb/tcl/docs/test.html b/bdb/tcl/docs/test.html deleted file mode 100644 index 603ae56a51e..00000000000 --- a/bdb/tcl/docs/test.html +++ /dev/null @@ -1,150 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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> - -<HR WIDTH="100%"> -<BR><B>> <env> mutex <I>mode nitems</I></B> -<P>This command creates a mutex region for testing. It sets the mode -of the region to <B><I>mode</I></B> and sets up for <B><I>nitems</I></B> -number of mutex entries. After we successfully get a handle to a -mutex we create a command of the form <B><I>$env.mutexX</I></B>, where -X is an integer starting at 0 (e.g. <B>$env.mutex0, $env.mutex1, -</B>etc). -We use the <I>Tcl_CreateObjCommand() </I> to create the top level -mutex function. It is through this handle that the user can access -all of the commands described below. Internally, the mutex handle -is sent as the <I>ClientData</I> portion of the new command set so that -all future mutex calls access the appropriate handle. -<P> -<HR WIDTH="100%"><B>> <mutex> close</B> -<P>This command closes the mutex and renders the handle invalid. -This command directly translates to the __db_r_detach 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%"><B>> <mutex> get <I>id</I></B> -<P>This command locks the mutex identified by <B><I>id</I></B>. It -returns either a 0 (for success), or it throws a Tcl error with a -system message. -<BR> -<HR WIDTH="100%"><B>> <mutex> release <I>id</I></B> -<P>This command releases the mutex identified by <B><I>id</I></B>. -It returns either a 0 (for success), or it throws a Tcl error with -a system message. -<BR> -<HR WIDTH="100%"><B>> <mutex> getval <I>id</I></B> -<P>This command gets the value stored for the mutex identified by <B><I>id</I></B>. -It returns either the value, or it throws a Tcl error with a system -message. -<BR> -<HR WIDTH="100%"><B>> <mutex> setval <I>id val</I></B> -<P>This command sets the value stored for the mutex identified by <B><I>id -</I></B>to -<B><I>val</I></B>. -It returns either a 0 (for success), or it throws a Tcl error with -a system message. -<BR> -<HR WIDTH="100%"> -<BR> -</BODY> -</HTML> diff --git a/bdb/tcl/docs/txn.html b/bdb/tcl/docs/txn.html deleted file mode 100644 index 07c88c0fe1d..00000000000 --- a/bdb/tcl/docs/txn.html +++ /dev/null @@ -1,67 +0,0 @@ -<!--Copyright 1999-2002 by Sleepycat Software, Inc.--> -<!--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>-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> - -<li> -<b>-min</b> causes the checkpoint to occur only if <b><i>min</i></b> minutes -have passed since the last checkpoint</li> -</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/bdb/tcl/tcl_compat.c b/bdb/tcl/tcl_compat.c deleted file mode 100644 index e77bc32aedf..00000000000 --- a/bdb/tcl/tcl_compat.c +++ /dev/null @@ -1,746 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_compat.c,v 11.39 2002/08/15 14:05:38 bostic Exp $"; -#endif /* not lint */ - -#if CONFIG_TEST - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <fcntl.h> -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#define DB_DBM_HSEARCH 1 - -#include "db_int.h" -#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 char *hcmds[] = { - "hcreate", - "hdestroy", - "hsearch", - NULL - }; - enum hcmds { - HHCREATE, - HHDESTROY, - HHSEARCH - }; - static 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(nelem) == 0 ? 1: 0; - _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(); - (void)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 char *ndbopen[] = { - "-create", - "-mode", - "-rdonly", - "-truncate", - "--", - NULL - }; - enum ndbopen { - NDB_CREATE, - NDB_MODE, - NDB_RDONLY, - NDB_TRUNC, - NDB_ENDARG - }; - - u_int32_t open_flags; - int endarg, i, mode, optindex, read_only, result, ret; - char *arg, *db; - - result = TCL_OK; - open_flags = 0; - endarg = mode = 0; - 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; - } /* 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, 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 char *dbmcmds[] = { - "dbmclose", - "dbminit", - "delete", - "fetch", - "firstkey", - "nextkey", - "store", - NULL - }; - enum dbmcmds { - DBMCLOSE, - DBMINIT, - DBMDELETE, - DBMFETCH, - DBMFIRST, - DBMNEXT, - DBMSTORE - }; - static 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; - /* - * 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); - } - _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); - } - _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 = 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, data.dsize + 1, &t)) != 0) - Tcl_SetResult(interp, "-1", TCL_STATIC); - else { - memcpy(t, data.dptr, 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 = 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 = 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); - } - _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 = 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); - } - _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, key.dsize + 1, &t)) != 0) - Tcl_SetResult(interp, "-1", TCL_STATIC); - else { - memcpy(t, key.dptr, 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 = 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, data.dsize + 1, &t)) != 0) - Tcl_SetResult(interp, "-1", TCL_STATIC); - else { - memcpy(t, data.dptr, data.dsize); - t[data.dsize] = '\0'; - Tcl_SetResult(interp, t, TCL_VOLATILE); - __os_free(NULL, t); - } - break; - } -out: - if (freedata) - (void)__os_free(NULL, dtmp); - if (freekey) - (void)__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 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) - _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, 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) - _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/bdb/tcl/tcl_db.c b/bdb/tcl/tcl_db.c deleted file mode 100644 index 7df2e48311c..00000000000 --- a/bdb/tcl/tcl_db.c +++ /dev/null @@ -1,2421 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2002 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_db.c,v 11.107 2002/08/06 06:20:31 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#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)); -static int tcl_DbKeyRange __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *)); -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 *)); -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_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 char *dbcmds[] = { -#if CONFIG_TEST - "keyrange", - "pget", - "rpcid", - "test", -#endif - "associate", - "close", - "count", - "cursor", - "del", - "get", - "get_join", - "get_type", - "is_byteswapped", - "join", - "put", - "stat", - "sync", - "truncate", - NULL - }; - enum dbcmds { -#if CONFIG_TEST - DBKEYRANGE, - DBPGET, - DBRPCID, - DBTEST, -#endif - DBASSOCIATE, - DBCLOSE, - DBCOUNT, - DBCURSOR, - DBDELETE, - DBGET, - DBGETJOIN, - DBGETTYPE, - DBSWAPPED, - DBJOIN, - DBPUT, - DBSTAT, - DBSYNC, - DBTRUNCATE - }; - DB *dbp; - DBC *dbc; - DBTCL_INFO *dbip; - DBTCL_INFO *ip; - DBTYPE type; - Tcl_Obj *res; - int cmdindex, isswapped, result, ret; - char newname[MSG_SIZE]; - - 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) { -#if 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(dbp->cl_id); - break; - case DBTEST: - result = tcl_EnvTest(interp, objc, objv, dbp->dbenv); - 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, &isswapped); - res = Tcl_NewIntObj(isswapped); - 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 = Tcl_NewStringObj("btree", strlen("btree")); - else if (type == DB_HASH) - res = Tcl_NewStringObj("hash", strlen("hash")); - else if (type == DB_RECNO) - res = Tcl_NewStringObj("recno", strlen("recno")); - else if (type == DB_QUEUE) - res = Tcl_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; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)dbc_Cmd, - (ClientData)dbc, NULL); - res = - Tcl_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; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)dbc_Cmd, - (ClientData)dbc, NULL); - res = - Tcl_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 DBGETJOIN: - result = tcl_DbGetjoin(interp, objc, objv, dbp); - 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 */ -{ - DB_BTREE_STAT *bsp; - DB_HASH_STAT *hsp; - DB_QUEUE_STAT *qsp; - void *sp; - Tcl_Obj *res, *flaglist, *myobjv[2]; - DBTYPE type; - u_int32_t flag; - int result, ret; - char *arg; - - result = TCL_OK; - flag = 0; - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?-faststat?"); - return (TCL_ERROR); - } - - if (objc == 3) { - arg = Tcl_GetStringFromObj(objv[2], NULL); - if (strcmp(arg, "-faststat") == 0) - flag = DB_FAST_STAT; - else { - Tcl_SetResult(interp, - "db stat: unknown arg", TCL_STATIC); - return (TCL_ERROR); - } - } - - _debug_check(); - ret = dbp->stat(dbp, &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("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_STAT_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 records", qsp->qs_nkeys); - 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_STAT_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); - 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("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] = Tcl_NewStringObj("Flags", strlen("Flags")); - myobjv[1] = _GetFlagsList(interp, dbp->flags, __db_inmemdbflags); - 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: - free(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 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); - } - - i = 2; - while (i < objc) { - 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; - } - i++; - 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; - } - _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 char *dbputopts[] = { -#if CONFIG_TEST - "-nodupdata", -#endif - "-append", - "-auto_commit", - "-nooverwrite", - "-partial", - "-txn", - NULL - }; - enum dbputopts { -#if CONFIG_TEST - DBGET_NODUPDATA, -#endif - DBPUT_APPEND, - DBPUT_AUTO_COMMIT, - DBPUT_NOOVER, - DBPUT_PART, - DBPUT_TXN - }; - static char *dbputapp[] = { - "-append", NULL - }; - enum dbputapp { DBPUT_APPEND0 }; - DBT key, data; - DBTYPE type; - DB_TXN *txn; - Tcl_Obj **elemv, *res; - void *dtmp, *ktmp; - db_recno_t recno; - u_int32_t flag; - int auto_commit, elemc, end, freekey, freedata; - int i, optindex, result, ret; - char *arg, msg[MSG_SIZE]; - - txn = NULL; - result = TCL_OK; - flag = 0; - if (objc <= 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?-args? key data"); - return (TCL_ERROR); - } - - freekey = freedata = 0; - memset(&key, 0, sizeof(key)); - memset(&data, 0, sizeof(data)); - - /* - * 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, 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; - if (type == DB_QUEUE || type == DB_RECNO) { - 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: - end = objc - 1; - break; - } - } - } - Tcl_ResetResult(interp); - - /* - * Get the command name index from the object based on the options - * defined above. - */ - i = 2; - auto_commit = 0; - 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) { -#if 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_AUTO_COMMIT: - auto_commit = 1; - break; - case DBPUT_APPEND: - FLAG_CHECK(flag); - flag = DB_APPEND; - break; - case DBPUT_NOOVER: - FLAG_CHECK(flag); - flag = DB_NOOVERWRITE; - 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 (auto_commit) - flag |= DB_AUTO_COMMIT; - - if (result == TCL_ERROR) - return (result); - - /* - * If we are a recno db and we are NOT using append, then the 2nd - * last arg is the key. - */ - if (type == DB_QUEUE || type == DB_RECNO) { - 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; - } - 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); - result = _ReturnSetup(interp, ret, DB_RETOK_DBPUT(ret), "db put"); - if (ret == 0 && - (type == DB_RECNO || type == DB_QUEUE) && flag == DB_APPEND) { - res = Tcl_NewLongObj((long)recno); - Tcl_SetObjResult(interp, res); - } -out: - if (freedata) - (void)__os_free(dbp->dbenv, dtmp); - if (freekey) - (void)__os_free(dbp->dbenv, ktmp); - 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 char *dbgetopts[] = { -#if CONFIG_TEST - "-dirty", - "-multi", -#endif - "-consume", - "-consume_wait", - "-get_both", - "-glob", - "-partial", - "-recno", - "-rmw", - "-txn", - "--", - NULL - }; - enum dbgetopts { -#if CONFIG_TEST - DBGET_DIRTY, - DBGET_MULTI, -#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 type; - DB_TXN *txn; - Tcl_Obj **elemv, *retlist; - void *dtmp, *ktmp; - u_int32_t flag, cflag, isdup, mflag, rmw; - int bufsize, elemc, end, endarg, freekey, freedata, i; - int optindex, result, ret, useglob, useprecno, userecno; - char *arg, *pattern, *prefix, msg[MSG_SIZE]; - db_recno_t precno, recno; - - result = TCL_OK; - freekey = freedata = 0; - cflag = endarg = flag = mflag = rmw = 0; - useglob = userecno = useprecno = 0; - txn = NULL; - pattern = prefix = NULL; - - 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) { -#if CONFIG_TEST - case DBGET_DIRTY: - rmw |= DB_DIRTY_READ; - break; - case DBGET_MULTI: - mflag |= DB_MULTIPLE; - result = Tcl_GetIntFromObj(interp, objv[i], &bufsize); - if (result != TCL_OK) - goto out; - i++; - 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; - } - 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; - } /* switch */ - 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; - } - - /* - * XXX - * We technically shouldn't be looking inside the dbp like this, - * but this is the only way to figure out whether the primary - * key should also be a recno. - */ - if (ispget) { - if (dbp->s_primary != NULL && - (dbp->s_primary->type == DB_RECNO || - dbp->s_primary->type == DB_QUEUE)) - useprecno = 1; - } - - /* - * 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; - } - 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. - * XXX - * When there is a db->get_flags method, it should be used. - * isdup = dbp->get_flags(dbp) & DB_DUP; - * For now we illegally peek. - * XXX - */ - isdup = dbp->flags & DB_AM_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 || - flag == DB_SET_RECNO || flag == DB_GET_BOTH || - flag == DB_CONSUME || flag == DB_CONSUME_WAIT)) { - 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], - &ktmp, &key.size, &freekey); - if (ret != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_DBGET(ret), "db get"); - goto out; - } - key.data = ktmp; - } - /* - * 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], - &ktmp, &key.size, &freekey); - if (ret != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_DBGET(ret), "db get"); - goto out; - } - key.data = ktmp; - } - if (mflag & DB_MULTIPLE) { - if ((ret = __os_malloc(dbp->dbenv, - bufsize, &save.data)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - goto out; - } - save.ulen = bufsize; - F_CLR(&save, DB_DBT_MALLOC); - F_SET(&save, DB_DBT_USERMEM); - } - } - - 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 thus if DB allocated - * anything). If DB_DBT_MALLOC is not set, this is a bulk - * get buffer, and needs to be freed no matter what. - */ - if (F_ISSET(&data, DB_DBT_MALLOC) && ret == 0) - __os_ufree(dbp->dbenv, data.data); - else if (!F_ISSET(&data, DB_DBT_MALLOC)) - __os_free(dbp->dbenv, data.data); - if (ispget && ret == 0) - __os_ufree(dbp->dbenv, 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], &ktmp, - &key.size, &freekey); - if (ret != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_DBGET(ret), "db get"); - return (result); - } - key.data = ktmp; - } - 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 = 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->c_pget(dbc, &key, &pkey, &data, cflag | rmw); - } else { - _debug_check(); - ret = dbc->c_get(dbc, &key, &data, cflag | rmw); - } - result = _ReturnSetup(interp, ret, DB_RETOK_DBCGET(ret), - "db get (cursor)"); - if (result == TCL_ERROR) - goto out1; - if (ret == 0 && pattern && - memcmp(key.data, prefix, strlen(prefix)) != 0) { - /* - * Free space from DB_DBT_MALLOC - */ - free(data.data); - goto out1; - } - if (pattern) - 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) - free(pkey.data); - free(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->c_pget(dbc, &key, &pkey, &data, cflag | rmw); - } else - ret = dbc->c_get(dbc, &key, &data, cflag | rmw); - if (ret == 0 && pattern && - memcmp(key.data, prefix, strlen(prefix)) != 0) { - /* - * Free space from DB_DBT_MALLOC - */ - free(data.data); - break; - } - } -out1: - dbc->c_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->dbenv, prefix); - if (freedata) - (void)__os_free(dbp->dbenv, dtmp); - if (freekey) - (void)__os_free(dbp->dbenv, 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 char *dbdelopts[] = { - "-auto_commit", - "-glob", - "-txn", - NULL - }; - enum dbdelopts { - DBDEL_AUTO_COMMIT, - DBDEL_GLOB, - DBDEL_TXN - }; - DBC *dbc; - DBT key, data; - DBTYPE type; - DB_TXN *txn; - void *ktmp; - db_recno_t recno; - int freekey, i, optindex, result, ret; - u_int32_t flag; - char *arg, *pattern, *prefix, msg[MSG_SIZE]; - - result = TCL_OK; - freekey = 0; - flag = 0; - pattern = prefix = NULL; - txn = NULL; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?-args? key"); - return (TCL_ERROR); - } - - memset(&key, 0, sizeof(key)); - /* - * The first arg must be -auto_commit, -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 -auto_commit, -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_AUTO_COMMIT: - flag |= DB_AUTO_COMMIT; - 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; - } - 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 we have a pattern and an auto commit flag, there is an error. - */ - 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 (flag & DB_AUTO_COMMIT) { - Tcl_SetResult(interp, - "Cannot use -auto_commit and patterns.\n", - TCL_STATIC); - 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 (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, flag); - /* - * If we have any error, set up return result and stop - * processing keys. - */ - if (freekey) - (void)__os_free(dbp->dbenv, ktmp); - 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 = strlen(prefix); - if (strlen(prefix) == 0) - flag = DB_FIRST; - else - flag = DB_SET_RANGE; - ret = dbc->c_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->c_del(dbc, 0); - 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->c_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->dbenv, prefix); - dbc->c_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 char *dbcuropts[] = { -#if CONFIG_TEST - "-dirty", - "-update", -#endif - "-txn", - NULL - }; - enum dbcuropts { -#if CONFIG_TEST - DBCUR_DIRTY, - DBCUR_UPDATE, -#endif - 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) { -#if CONFIG_TEST - case DBCUR_DIRTY: - flag |= DB_DIRTY_READ; - break; - case DBCUR_UPDATE: - flag |= DB_WRITECURSOR; - break; -#endif - 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 char *dbaopts[] = { - "-auto_commit", - "-create", - "-txn", - NULL - }; - enum dbaopts { - DBA_AUTO_COMMIT, - DBA_CREATE, - DBA_TXN - }; - DB *sdbp; - DB_TXN *txn; - DBTCL_INFO *sdbip; - int i, optindex, result, ret; - char *arg, msg[MSG_SIZE]; - u_int32_t flag; - - 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_AUTO_COMMIT: - flag |= DB_AUTO_COMMIT; - break; - case DBA_CREATE: - flag |= DB_CREATE; - 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; - if (i != objc - 1) { - /* - * 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; -{ - DBTCL_INFO *ip; - Tcl_Interp *interp; - Tcl_Obj *pobj, *dobj, *objv[3]; - int len, result, ret; - 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, pkey->size); - Tcl_IncrRefCount(pobj); - dobj = Tcl_NewByteArrayObj(data->data, 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_err(dbp->dbenv, - "Tcl callback function failed with code %d", result); - return (EINVAL); - } - - retbuf = - Tcl_GetByteArrayFromObj(Tcl_GetObjResult(interp), &len); - - /* - * 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->dbenv, len, &databuf)) != 0) - return (ret); - memcpy(databuf, retbuf, len); - - skey->data = databuf; - skey->size = len; - F_SET(skey, 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 char *dbjopts[] = { - "-nosort", - NULL - }; - enum dbjopts { - DBJ_NOSORT - }; - DBC **listp; - u_int32_t flag; - int adj, i, j, optindex, size, 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); - } - - i = 2; - adj = i; - while (i < objc) { - 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; - } - i++; - 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 *) * ((objc - adj) + 1); - ret = __os_malloc(dbp->dbenv, 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->dbenv, 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 char *dbgetjopts[] = { -#if CONFIG_TEST - "-nosort", -#endif - "-txn", - NULL - }; - enum dbgetjopts { -#if 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; - u_int32_t flag; - int adj, elemc, freekey, i, j, optindex, result, ret, size; - char *arg, msg[MSG_SIZE]; - - result = TCL_OK; - flag = 0; - 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) { -#if 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 *) * ((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])->c_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->c_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); - free(key.data); - free(data.data); - } - } - dbc->c_close(dbc); - if (result == TCL_OK) - Tcl_SetObjResult(interp, retlist); -out: - if (freekey) - (void)__os_free(dbp->dbenv, ktmp); - while (j) { - if (listp[j]) - (listp[j])->c_close(listp[j]); - j--; - } - __os_free(dbp->dbenv, listp); - 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 */ -{ - Tcl_Obj *res; - DBC *dbc; - DBT key, data; - void *ktmp; - db_recno_t count, recno; - int freekey, result, ret; - - result = TCL_OK; - count = 0; - freekey = 0; - res = NULL; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "key"); - return (TCL_ERROR); - } - - memset(&key, 0, sizeof(key)); - - /* - * 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. - */ - ret = 0; - 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->c_get(dbc, &key, &data, DB_SET); - if (ret == DB_NOTFOUND) - count = 0; - else { - ret = dbc->c_count(dbc, &count, 0); - if (ret != 0) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db c count"); - goto out; - } - } - res = Tcl_NewLongObj((long)count); - Tcl_SetObjResult(interp, res); -out: - if (freekey) - (void)__os_free(dbp->dbenv, ktmp); - (void)dbc->c_close(dbc); - return (result); -} - -#if 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 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]; - - result = TCL_OK; - flag = 0; - freekey = 0; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?-txn id? key"); - return (TCL_ERROR); - } - - txn = NULL; - i = 2; - while (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 (freekey) - (void)__os_free(dbp->dbenv, 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 char *dbcuropts[] = { - "-auto_commit", - "-txn", - NULL - }; - enum dbcuropts { - DBTRUNC_AUTO_COMMIT, - DBTRUNC_TXN - }; - DB_TXN *txn; - Tcl_Obj *res; - u_int32_t count, flag; - int i, optindex, result, ret; - char *arg, msg[MSG_SIZE]; - - txn = NULL; - flag = 0; - 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_AUTO_COMMIT: - flag |= DB_AUTO_COMMIT; - break; - 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, flag); - if (ret != 0) - result = _ErrorSetup(interp, ret, "db truncate"); - - else { - res = Tcl_NewLongObj((long)count); - Tcl_SetObjResult(interp, res); - } -out: - return (result); -} diff --git a/bdb/tcl/tcl_db_pkg.c b/bdb/tcl/tcl_db_pkg.c deleted file mode 100644 index ce37598dc1a..00000000000 --- a/bdb/tcl/tcl_db_pkg.c +++ /dev/null @@ -1,3117 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2002 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_db_pkg.c,v 11.141 2002/08/14 20:15:47 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#if CONFIG_TEST -#define DB_DBM_HSEARCH 1 -#endif - -#include "db_int.h" -#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_DbUpgrade __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); -static int bdb_DbVerify __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); -static int bdb_Version __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); -static int bdb_Handles __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 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_rep_send __P((DB_ENV *, - const DBT *, const DBT *, int, u_int32_t)); - -#ifdef TEST_ALLOC -static void * tcl_db_malloc __P((size_t)); -static void * tcl_db_realloc __P((void *, size_t)); -static void tcl_db_free __P((void *)); -#endif - -/* - * 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; - - code = Tcl_PkgProvide(interp, "Db_tcl", "1.0"); - if (code != TCL_OK) - return (code); - - Tcl_CreateObjCommand(interp, "berkdb", (Tcl_ObjCmdProc *)berkdb_Cmd, - (ClientData)0, NULL); - /* - * Create shared global debugging variables - */ - Tcl_LinkVar(interp, "__debug_on", (char *)&__debug_on, TCL_LINK_INT); - Tcl_LinkVar(interp, "__debug_print", (char *)&__debug_print, - TCL_LINK_INT); - Tcl_LinkVar(interp, "__debug_stop", (char *)&__debug_stop, - TCL_LINK_INT); - 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 char *berkdbcmds[] = { -#if CONFIG_TEST - "dbverify", - "handles", - "upgrade", -#endif - "dbremove", - "dbrename", - "env", - "envremove", - "open", - "version", -#if 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 { -#if CONFIG_TEST - BDB_DBVERIFY, - BDB_HANDLES, - BDB_UPGRADE, -#endif - BDB_DBREMOVE, - BDB_DBRENAME, - BDB_ENV, - BDB_ENVREMOVE, - BDB_OPEN, - BDB_VERSION, -#if 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; - - DB *dbp; -#if CONFIG_TEST - DBM *ndbmp; - static int ndbm_id = 0; -#endif - DBTCL_INFO *ip; - DB_ENV *envp; - 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) { -#if CONFIG_TEST - case BDB_DBVERIFY: - result = bdb_DbVerify(interp, objc, objv); - break; - case BDB_HANDLES: - result = bdb_Handles(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, &envp); - if (result == TCL_OK && envp != NULL) { - env_id++; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)env_Cmd, - (ClientData)envp, NULL); - /* Use ip->i_name - newname is overwritten */ - res = - Tcl_NewStringObj(newname, strlen(newname)); - _SetInfoData(ip, envp); - } 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++; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)db_Cmd, - (ClientData)dbp, NULL); - /* Use ip->i_name - newname is overwritten */ - res = - Tcl_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; -#if 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++; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)ndbm_Cmd, - (ClientData)ndbmp, NULL); - /* Use ip->i_name - newname is overwritten */ - res = - Tcl_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, env) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DBTCL_INFO *ip; /* Our internal info */ - DB_ENV **env; /* Environment pointer */ -{ - static char *envopen[] = { -#if CONFIG_TEST - "-auto_commit", - "-cdb", - "-cdb_alldb", - "-client_timeout", - "-lock", - "-lock_conflict", - "-lock_detect", - "-lock_max", - "-lock_max_locks", - "-lock_max_lockers", - "-lock_max_objects", - "-lock_timeout", - "-log", - "-log_buffer", - "-log_max", - "-log_regionmax", - "-mmapsize", - "-nommap", - "-overwrite", - "-region_init", - "-rep_client", - "-rep_logsonly", - "-rep_master", - "-rep_transport", - "-server", - "-server_timeout", - "-txn_timeout", - "-txn_timestamp", - "-verbose", - "-wrnosync", -#endif - "-cachesize", - "-create", - "-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 { -#if CONFIG_TEST - ENV_AUTO_COMMIT, - ENV_CDB, - ENV_CDB_ALLDB, - ENV_CLIENT_TO, - ENV_LOCK, - ENV_CONFLICT, - ENV_DETECT, - ENV_LOCK_MAX, - ENV_LOCK_MAX_LOCKS, - ENV_LOCK_MAX_LOCKERS, - ENV_LOCK_MAX_OBJECTS, - ENV_LOCK_TIMEOUT, - ENV_LOG, - ENV_LOG_BUFFER, - ENV_LOG_MAX, - ENV_LOG_REGIONMAX, - ENV_MMAPSIZE, - ENV_NOMMAP, - ENV_OVERWRITE, - ENV_REGION_INIT, - ENV_REP_CLIENT, - ENV_REP_LOGSONLY, - ENV_REP_MASTER, - ENV_REP_TRANSPORT, - ENV_SERVER, - ENV_SERVER_TO, - ENV_TXN_TIMEOUT, - ENV_TXN_TIME, - ENV_VERBOSE, - ENV_WRNOSYNC, -#endif - ENV_CACHESIZE, - ENV_CREATE, - ENV_DATA_DIR, - ENV_ENCRYPT_AES, - ENV_ENCRYPT_ANY, - ENV_ERRFILE, - ENV_ERRPFX, - ENV_HOME, - ENV_LOG_DIR, - ENV_MODE, - ENV_PRIVATE, - ENV_RECOVER, - ENV_RECOVER_FATAL, - ENV_SHM_KEY, - ENV_SYSTEM_MEM, - ENV_TMP_DIR, - ENV_TXN, - ENV_TXN_MAX, - ENV_USE_ENVIRON, - ENV_USE_ENVIRON_ROOT - }; - Tcl_Obj **myobjv, **myobjv1; - time_t timestamp; - u_int32_t detect, gbytes, bytes, ncaches, logbufset, logmaxset; - u_int32_t open_flags, rep_flags, set_flags, size, uintarg; - u_int8_t *conflicts; - int i, intarg, j, mode, myobjc, nmodes, optindex; - int result, ret, temp; - long client_to, server_to, shm; - char *arg, *home, *passwd, *server; - - result = TCL_OK; - mode = 0; - rep_flags = set_flags = 0; - home = NULL; - - /* - * XXX - * If/when our Tcl interface becomes thread-safe, we should enable - * DB_THREAD here in all cases. For now, turn it on only when testing - * so that we exercise MUTEX_THREAD_LOCK cases. - * - * Historically, a key stumbling block was the log_get interface, - * which could only do relative operations in a non-threaded - * environment. This is no longer an issue, thanks to log cursors, - * but 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. - */ - open_flags = DB_JOINENV | -#ifdef TEST_THREAD - DB_THREAD; -#else - 0; -#endif - 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; - } - switch ((enum envopen)optindex) { -#if CONFIG_TEST - case ENV_SERVER: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-server hostname"); - result = TCL_ERROR; - break; - } - server = Tcl_GetStringFromObj(objv[i++], NULL); - break; - case ENV_SERVER_TO: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-server_to secs"); - result = TCL_ERROR; - break; - } - result = Tcl_GetLongFromObj(interp, objv[i++], - &server_to); - break; - case ENV_CLIENT_TO: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-client_to secs"); - result = TCL_ERROR; - break; - } - result = Tcl_GetLongFromObj(interp, objv[i++], - &client_to); - break; -#endif - default: - break; - } - } - if (server != NULL) { - ret = db_env_create(env, DB_CLIENT); - if (ret) - return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_env_create")); - (*env)->set_errpfx((*env), ip->i_name); - (*env)->set_errcall((*env), _ErrorFunc); - if ((ret = (*env)->set_rpc_server((*env), NULL, server, - client_to, server_to, 0)) != 0) { - result = TCL_ERROR; - goto error; - } - } else { - /* - * Create the environment handle before parsing the args - * since we'll be modifying the environment as we parse. - */ - ret = db_env_create(env, 0); - if (ret) - return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_env_create")); - (*env)->set_errpfx((*env), ip->i_name); - (*env)->set_errcall((*env), _ErrorFunc); - } - - /* Hang our info pointer on the env handle, so we can do callbacks. */ - (*env)->app_private = ip; - - /* - * Use a Tcl-local alloc and free function so that we're sure to - * test whether we use umalloc/ufree in the right places. - */ -#ifdef TEST_ALLOC - (*env)->set_alloc(*env, tcl_db_malloc, tcl_db_realloc, tcl_db_free); -#endif - - /* - * 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) { -#if CONFIG_TEST - case ENV_SERVER: - case ENV_SERVER_TO: - case ENV_CLIENT_TO: - /* - * Already handled these, skip them and their arg. - */ - i++; - break; - case ENV_AUTO_COMMIT: - FLD_SET(set_flags, DB_AUTO_COMMIT); - break; - case ENV_CDB: - FLD_SET(open_flags, DB_INIT_CDB | DB_INIT_MPOOL); - FLD_CLR(open_flags, DB_JOINENV); - break; - case ENV_CDB_ALLDB: - FLD_SET(set_flags, DB_CDB_ALLDB); - break; - case ENV_LOCK: - FLD_SET(open_flags, DB_INIT_LOCK | DB_INIT_MPOOL); - FLD_CLR(open_flags, DB_JOINENV); - break; - case 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; - } - size = sizeof(u_int8_t) * nmodes*nmodes; - ret = __os_malloc(*env, size, &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 = (*env)->set_lk_conflicts(*env, - (u_int8_t *)conflicts, nmodes); - __os_free(NULL, conflicts); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_lk_conflicts"); - break; - case 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, "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 = (*env)->set_lk_detect(*env, detect); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "lock_detect"); - break; - case ENV_LOCK_MAX: - case ENV_LOCK_MAX_LOCKS: - case ENV_LOCK_MAX_LOCKERS: - case ENV_LOCK_MAX_OBJECTS: - 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 ENV_LOCK_MAX: - ret = (*env)->set_lk_max(*env, - uintarg); - break; - case ENV_LOCK_MAX_LOCKS: - ret = (*env)->set_lk_max_locks(*env, - uintarg); - break; - case ENV_LOCK_MAX_LOCKERS: - ret = (*env)->set_lk_max_lockers(*env, - uintarg); - break; - case ENV_LOCK_MAX_OBJECTS: - ret = (*env)->set_lk_max_objects(*env, - uintarg); - break; - default: - break; - } - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "lock_max"); - } - break; - case ENV_TXN_TIME: - case ENV_TXN_TIMEOUT: - case ENV_LOCK_TIMEOUT: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-txn_timestamp time?"); - result = TCL_ERROR; - break; - } - result = Tcl_GetLongFromObj(interp, objv[i++], - (long *)×tamp); - if (result == TCL_OK) { - _debug_check(); - if (optindex == ENV_TXN_TIME) - ret = (*env)-> - set_tx_timestamp(*env, ×tamp); - else - ret = (*env)->set_timeout(*env, - (db_timeout_t)timestamp, - optindex == ENV_TXN_TIMEOUT ? - DB_SET_TXN_TIMEOUT : - DB_SET_LOCK_TIMEOUT); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "txn_timestamp"); - } - break; - case ENV_LOG: - FLD_SET(open_flags, DB_INIT_LOG | DB_INIT_MPOOL); - FLD_CLR(open_flags, DB_JOINENV); - break; - case 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 = (*env)->set_lg_bsize(*env, uintarg); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "log_bsize"); - logbufset = 1; - if (logmaxset) { - _debug_check(); - ret = (*env)->set_lg_max(*env, - logmaxset); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "log_max"); - logmaxset = 0; - logbufset = 0; - } - } - break; - case 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 = (*env)->set_lg_max(*env, uintarg); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "log_max"); - logbufset = 0; - } else - logmaxset = uintarg; - break; - case 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 = (*env)->set_lg_regionmax(*env, uintarg); - result = - _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "log_regionmax"); - } - break; - case ENV_MMAPSIZE: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-mmapsize size?"); - result = TCL_ERROR; - break; - } - result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); - if (result == TCL_OK) { - _debug_check(); - ret = (*env)->set_mp_mmapsize(*env, - (size_t)intarg); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "mmapsize"); - } - break; - case ENV_NOMMAP: - FLD_SET(set_flags, DB_NOMMAP); - break; - case ENV_OVERWRITE: - FLD_SET(set_flags, DB_OVERWRITE); - break; - case ENV_REGION_INIT: - _debug_check(); - ret = (*env)->set_flags(*env, DB_REGION_INIT, 1); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "region_init"); - break; - case ENV_REP_CLIENT: - rep_flags = DB_REP_CLIENT; - break; - case ENV_REP_LOGSONLY: - rep_flags = DB_REP_LOGSONLY; - break; - case ENV_REP_MASTER: - rep_flags = DB_REP_MASTER; - break; - case ENV_REP_TRANSPORT: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "-rep_transport {envid sendproc}"); - result = TCL_ERROR; - break; - } - - /* - * 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 set_rep_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. - */ - result = Tcl_ListObjGetElements(interp, objv[i++], - &myobjc, &myobjv); - if (myobjc != 2) { - Tcl_SetResult(interp, - "List must be {envid sendproc}", - TCL_STATIC); - result = TCL_ERROR; - break; - } - - /* - * 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. - */ - ip->i_rep_eid = myobjv[0]; - Tcl_IncrRefCount(ip->i_rep_eid); - result = Tcl_GetIntFromObj(interp, - ip->i_rep_eid, &intarg); - if (result != TCL_OK) - break; - - ip->i_rep_send = myobjv[1]; - Tcl_IncrRefCount(ip->i_rep_send); - _debug_check(); - ret = (*env)->set_rep_transport(*env, - intarg, tcl_rep_send); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_rep_transport"); - break; - case 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, *env, - myobjv[0], myobjv[1]); - break; - case ENV_WRNOSYNC: - FLD_SET(set_flags, DB_TXN_WRITE_NOSYNC); - break; -#endif - case ENV_TXN: - FLD_SET(open_flags, DB_INIT_LOCK | - DB_INIT_LOG | DB_INIT_MPOOL | DB_INIT_TXN); - FLD_CLR(open_flags, DB_JOINENV); - /* Make sure we have an arg to check against! */ - if (i < objc) { - arg = Tcl_GetStringFromObj(objv[i], NULL); - if (strcmp(arg, "nosync") == 0) { - FLD_SET(set_flags, DB_TXN_NOSYNC); - i++; - } - } - break; - case ENV_CREATE: - FLD_SET(open_flags, DB_CREATE | DB_INIT_MPOOL); - FLD_CLR(open_flags, DB_JOINENV); - break; - case 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 = (*env)->set_encrypt(*env, passwd, DB_ENCRYPT_AES); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_encrypt"); - break; - case 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 = (*env)->set_encrypt(*env, passwd, 0); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_encrypt"); - break; - case 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 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 ENV_PRIVATE: - FLD_SET(open_flags, DB_PRIVATE | DB_INIT_MPOOL); - FLD_CLR(open_flags, DB_JOINENV); - break; - case ENV_RECOVER: - FLD_SET(open_flags, DB_RECOVER); - break; - case ENV_RECOVER_FATAL: - FLD_SET(open_flags, DB_RECOVER_FATAL); - break; - case ENV_SYSTEM_MEM: - FLD_SET(open_flags, DB_SYSTEM_MEM); - break; - case ENV_USE_ENVIRON_ROOT: - FLD_SET(open_flags, DB_USE_ENVIRON_ROOT); - break; - case ENV_USE_ENVIRON: - FLD_SET(open_flags, DB_USE_ENVIRON); - break; - case 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 = _GetUInt32(interp, myobjv[2], &ncaches); - if (result != TCL_OK) - break; - _debug_check(); - ret = (*env)->set_cachesize(*env, gbytes, bytes, - ncaches); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_cachesize"); - break; - case 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 = (*env)->set_shm_key(*env, shm); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "shm_key"); - } - break; - case 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 = (*env)->set_tx_max(*env, uintarg); - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "txn_max"); - } - break; - case ENV_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 (ip->i_err != NULL) - fclose(ip->i_err); - ip->i_err = fopen(arg, "a"); - if (ip->i_err != NULL) { - _debug_check(); - (*env)->set_errfile(*env, ip->i_err); - } - break; - case ENV_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 (ip->i_errpfx != NULL) - __os_free(NULL, ip->i_errpfx); - if ((ret = - __os_strdup(*env, arg, &ip->i_errpfx)) != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "__os_strdup"); - break; - } - if (ip->i_errpfx != NULL) { - _debug_check(); - (*env)->set_errpfx(*env, ip->i_errpfx); - } - break; - case ENV_DATA_DIR: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "-data_dir dir"); - result = TCL_ERROR; - break; - } - arg = Tcl_GetStringFromObj(objv[i++], NULL); - _debug_check(); - ret = (*env)->set_data_dir(*env, arg); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_data_dir"); - break; - case 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 = (*env)->set_lg_dir(*env, arg); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_lg_dir"); - break; - case 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 = (*env)->set_tmp_dir(*env, 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 = (*env)->set_lg_max(*env, (u_int32_t)logmaxset); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "log_max"); - } - - if (result != TCL_OK) - goto error; - - if (set_flags) { - ret = (*env)->set_flags(*env, 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 = (*env)->open(*env, home, open_flags, mode); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env open"); - - if (rep_flags != 0 && result == TCL_OK) { - _debug_check(); - ret = (*env)->rep_start(*env, NULL, rep_flags); - result = _ReturnSetup(interp, - ret, DB_RETOK_STD(ret), "rep_start"); - } - -error: if (result == TCL_ERROR) { - if (ip->i_err) { - fclose(ip->i_err); - ip->i_err = NULL; - } - (void)(*env)->close(*env, 0); - *env = NULL; - } - 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 char *bdbenvopen[] = { - "-env", NULL - }; - enum bdbenvopen { - TCL_DB_ENV0 - }; - static char *bdbopen[] = { -#if CONFIG_TEST - "-btcompare", - "-dirty", - "-dupcompare", - "-hashproc", - "-lorder", - "-minkey", - "-nommap", - "-revsplitoff", - "-test", -#endif - "-auto_commit", - "-btree", - "-cachesize", - "-chksum", - "-create", - "-delim", - "-dup", - "-dupsort", - "-encrypt", - "-encryptaes", - "-encryptany", - "-env", - "-errfile", - "-errpfx", - "-excl", - "-extent", - "-ffactor", - "-hash", - "-len", - "-mode", - "-nelem", - "-pad", - "-pagesize", - "-queue", - "-rdonly", - "-recno", - "-recnum", - "-renumber", - "-snapshot", - "-source", - "-truncate", - "-txn", - "-unknown", - "--", - NULL - }; - enum bdbopen { -#if CONFIG_TEST - TCL_DB_BTCOMPARE, - TCL_DB_DIRTY, - TCL_DB_DUPCOMPARE, - TCL_DB_HASHPROC, - TCL_DB_LORDER, - TCL_DB_MINKEY, - TCL_DB_NOMMAP, - TCL_DB_REVSPLIT, - TCL_DB_TEST, -#endif - TCL_DB_AUTO_COMMIT, - TCL_DB_BTREE, - TCL_DB_CACHESIZE, - TCL_DB_CHKSUM, - TCL_DB_CREATE, - 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_LEN, - TCL_DB_MODE, - 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 - }; - - DBTCL_INFO *envip, *errip; - DB_TXN *txn; - DBTYPE type; - DB_ENV *envp; - Tcl_Obj **myobjv; - u_int32_t gbytes, bytes, ncaches, open_flags, uintarg; - int endarg, i, intarg, mode, myobjc; - int optindex, result, ret, set_err, set_flags, 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; - db = subdb = NULL; - - /* - * XXX - * If/when our Tcl interface becomes thread-safe, we should enable - * DB_THREAD here in all cases. See comment in bdb_EnvOpen(). - * For now, just turn it on when testing so that we exercise - * MUTEX_THREAD_LOCK cases. - */ - open_flags = -#ifdef TEST_THREAD - DB_THREAD; -#else - 0; -#endif - envp = NULL; - txn = 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); - envp = NAME_TO_ENV(arg); - if (envp == 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, envp, 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 when err stuff is not tied to env. - * - * The DB->set_err* functions actually overwrite in the - * environment. So, if we are explicitly using an env, - * don't overwrite what we have already set up. If we are - * not using one, then we set up since we get a private - * default env. - */ - /* XXX - remove this conditional if/when err is not tied to env */ - if (envp == NULL) { - (*dbp)->set_errpfx((*dbp), ip->i_name); - (*dbp)->set_errcall((*dbp), _ErrorFunc); - } - envip = _PtrToInfo(envp); /* XXX */ - /* - * If we are using an env, we keep track of err info in the env's ip. - * Otherwise use the DB's ip. - */ - 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) { -#if 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_btcompare = objv[i++]; - Tcl_IncrRefCount(ip->i_btcompare); - _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_DIRTY: - open_flags |= DB_DIRTY_READ; - 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_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 = _GetUInt32(interp, objv[i++], &uintarg); - if (result == TCL_OK) { - _debug_check(); - ret = (*dbp)->set_lorder(*dbp, uintarg); - 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_REVSPLIT: - set_flags |= DB_REVSPLITOFF; - break; - case TCL_DB_TEST: - (*dbp)->set_h_hash(*dbp, __ham_test); - 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, - "Put: 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_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_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_SHA1; - 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_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_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_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 = _GetUInt32(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) - fclose(errip->i_err); - 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)->dbenv, - 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 (i != objc) { - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &subdblen); - if ((ret = __os_malloc(envp, - subdblen + 1, &subdb)) != 0) { - Tcl_SetResult(interp, db_strerror(ret), - TCL_STATIC); - return (0); - } - memcpy(subdb, subdbtmp, 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 (subdb) - __os_free(envp, 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) { - fclose(errip->i_err); - errip->i_err = NULL; - } - if (set_pfx && errip && errip->i_errpfx != NULL) { - __os_free(envp, errip->i_errpfx); - errip->i_errpfx = NULL; - } - *dbp = NULL; - } - return (result); -} - -/* - * 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 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 *envp; - DB_TXN *txn; - int endarg, i, optindex, result, ret, subdblen; - u_int32_t enc_flag, iflags, set_flags; - u_char *subdbtmp; - char *arg, *db, msg[MSG_SIZE], *passwd, *subdb; - - db = subdb = NULL; - dbp = NULL; - endarg = 0; - envp = NULL; - iflags = enc_flag = set_flags = 0; - passwd = NULL; - result = TCL_OK; - subdbtmp = NULL; - txn = 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); - envp = NAME_TO_ENV(arg); - if (envp == NULL) { - Tcl_SetResult(interp, - "db remove: illegal environment", - TCL_STATIC); - return (TCL_ERROR); - } - 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 (i != objc) { - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &subdblen); - if ((ret = __os_malloc(envp, subdblen + 1, - &subdb)) != 0) { Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(subdb, subdbtmp, subdblen); - subdb[subdblen] = '\0'; - } - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?"); - result = TCL_ERROR; - goto error; - } - if (envp == NULL) { - ret = db_create(&dbp, envp, 0); - if (ret) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_create"); - goto error; - } - - 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"); - } - } - - /* - * No matter what, we NULL out dbp after this call. - */ - _debug_check(); - if (dbp == NULL) - ret = envp->dbremove(envp, 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(envp, subdb); - if (result == TCL_ERROR && dbp != NULL) - (void)dbp->close(dbp, 0); - return (result); -} - -/* - * bdb_DbRename -- - * Implements the DBENV->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 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 *envp; - DB_TXN *txn; - 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; - - db = newname = subdb = NULL; - dbp = NULL; - endarg = 0; - envp = NULL; - iflags = enc_flag = set_flags = 0; - passwd = NULL; - result = TCL_OK; - subdbtmp = NULL; - txn = 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); - envp = NAME_TO_ENV(arg); - if (envp == NULL) { - Tcl_SetResult(interp, - "db rename: illegal environment", - TCL_STATIC); - return (TCL_ERROR); - } - 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 (i == objc - 2) { - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &subdblen); - if ((ret = __os_malloc(envp, subdblen + 1, - &subdb)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(subdb, subdbtmp, subdblen); - subdb[subdblen] = '\0'; - } - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &newlen); - if ((ret = __os_malloc(envp, newlen + 1, - &newname)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(newname, subdbtmp, newlen); - newname[newlen] = '\0'; - } else { - Tcl_WrongNumArgs( - interp, 3, objv, "?args? filename ?database? ?newname?"); - result = TCL_ERROR; - goto error; - } - if (envp == NULL) { - ret = db_create(&dbp, envp, 0); - if (ret) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_create"); - goto error; - } - 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"); - } - } - - /* - * No matter what, we NULL out dbp after this call. - */ - if (dbp == NULL) - ret = envp->dbrename(envp, 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(envp, subdb); - if (newname) - __os_free(envp, newname); - if (result == TCL_ERROR && dbp != NULL) - (void)dbp->close(dbp, 0); - return (result); -} - -#if CONFIG_TEST -/* - * bdb_DbVerify -- - * Implements the DB->verify command. - */ -static int -bdb_DbVerify(interp, objc, objv) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ -{ - static char *bdbverify[] = { - "-encrypt", - "-encryptaes", - "-encryptany", - "-env", - "-errfile", - "-errpfx", - "--", - NULL - }; - enum bdbvrfy { - TCL_DBVRFY_ENCRYPT, - TCL_DBVRFY_ENCRYPT_AES, - TCL_DBVRFY_ENCRYPT_ANY, - TCL_DBVRFY_ENV, - TCL_DBVRFY_ERRFILE, - TCL_DBVRFY_ERRPFX, - TCL_DBVRFY_ENDARG - }; - DB_ENV *envp; - DB *dbp; - FILE *errf; - u_int32_t enc_flag, flags, set_flags; - int endarg, i, optindex, result, ret; - char *arg, *db, *errpfx, *passwd; - - envp = NULL; - dbp = NULL; - passwd = NULL; - result = TCL_OK; - db = errpfx = NULL; - errf = 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_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); - envp = NAME_TO_ENV(arg); - if (envp == 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) - fclose(errf); - 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(envp, errpfx); - if ((ret = __os_strdup(NULL, arg, &errpfx)) != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_STD(ret), "__os_strdup"); - break; - } - 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. - */ - 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, envp, 0); - if (ret) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_create"); - goto error; - } - - 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"); - } - if (errf != NULL) - dbp->set_errfile(dbp, errf); - if (errpfx != NULL) - dbp->set_errpfx(dbp, errpfx); - - ret = dbp->verify(dbp, db, NULL, NULL, flags); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db verify"); -error: - if (errf != NULL) - fclose(errf); - if (errpfx != NULL) - __os_free(envp, 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 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 = Tcl_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); -} - -#if CONFIG_TEST -/* - * 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); - - for (p = LIST_FIRST(&__db_infohead); p != NULL; - p = LIST_NEXT(p, entries)) { - handle = Tcl_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); -} -#endif - -#if CONFIG_TEST -/* - * 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 char *bdbupg[] = { - "-dupsort", "-env", "--", NULL - }; - enum bdbupg { - TCL_DBUPG_DUPSORT, - TCL_DBUPG_ENV, - TCL_DBUPG_ENDARG - }; - DB_ENV *envp; - DB *dbp; - u_int32_t flags; - int endarg, i, optindex, result, ret; - char *arg, *db; - - envp = 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); - envp = NAME_TO_ENV(arg); - if (envp == 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, envp, 0); - if (ret) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_create"); - goto error; - } - - 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); -} -#endif - -/* - * 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_btcompare, "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_btcompare 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, dbta->size); - Tcl_IncrRefCount(a); - b = Tcl_NewByteArrayObj(dbtb->data, 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_err(dbp->dbenv, "Tcl %s callback failed", errname); - DB_ASSERT(0); - return (__db_panic(dbp->dbenv, 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, len); - Tcl_IncrRefCount(objv[1]); - result = Tcl_EvalObjv(interp, 2, objv, 0); - if (result != TCL_OK) { - /* - * XXX - * We drop core on error. See the comment in - * tcl_compare_callback. - */ -panic: __db_err(dbp->dbenv, "Tcl h_hash callback failed"); - DB_ASSERT(0); - return (__db_panic(dbp->dbenv, DB_RUNRECOVERY)); - } - - result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &hval); - if (result != TCL_OK) - goto panic; - - Tcl_DecrRefCount(objv[1]); - return (hval); -} - -/* - * tcl_rep_send -- - * Replication send callback. - */ -static int -tcl_rep_send(dbenv, control, rec, eid, flags) - DB_ENV *dbenv; - const DBT *control, *rec; - int eid; - u_int32_t flags; -{ - DBTCL_INFO *ip; - Tcl_Interp *interp; - Tcl_Obj *control_o, *eid_o, *origobj, *rec_o, *resobj, *objv[5]; - int result, ret; - - COMPQUIET(flags, 0); - - ip = (DBTCL_INFO *)dbenv->app_private; - interp = ip->i_interp; - objv[0] = ip->i_rep_send; - - control_o = Tcl_NewByteArrayObj(control->data, control->size); - Tcl_IncrRefCount(control_o); - - rec_o = Tcl_NewByteArrayObj(rec->data, rec->size); - Tcl_IncrRefCount(rec_o); - - eid_o = Tcl_NewIntObj(eid); - Tcl_IncrRefCount(eid_o); - - objv[1] = control_o; - objv[2] = rec_o; - objv[3] = ip->i_rep_eid; /* From ID */ - objv[4] = eid_o; /* To ID */ - - /* - * 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, 5, 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_err(dbenv, "Tcl rep_send failure"); - 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); - - return (ret); -} - -#ifdef TEST_ALLOC -/* - * 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, 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, 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); -} -#endif diff --git a/bdb/tcl/tcl_dbcursor.c b/bdb/tcl/tcl_dbcursor.c deleted file mode 100644 index fb426e53f48..00000000000 --- a/bdb/tcl/tcl_dbcursor.c +++ /dev/null @@ -1,924 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_dbcursor.c,v 11.51 2002/08/06 06:20:59 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" - -/* - * Prototypes for procedures defined later in this file: - */ -static int tcl_DbcDup __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *)); -static int tcl_DbcGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *, int)); -static int tcl_DbcPut __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBC *)); - -/* - * PUBLIC: int dbc_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); - * - * dbc_cmd -- - * Implements the cursor command. - */ -int -dbc_Cmd(clientData, interp, objc, objv) - ClientData clientData; /* Cursor handle */ - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ -{ - static char *dbccmds[] = { -#if CONFIG_TEST - "pget", -#endif - "close", - "del", - "dup", - "get", - "put", - NULL - }; - enum dbccmds { -#if CONFIG_TEST - DBCPGET, -#endif - DBCCLOSE, - DBCDELETE, - DBCDUP, - DBCGET, - DBCPUT - }; - DBC *dbc; - DBTCL_INFO *dbip; - int cmdindex, result, ret; - - Tcl_ResetResult(interp); - dbc = (DBC *)clientData; - dbip = _PtrToInfo((void *)dbc); - result = TCL_OK; - - if (objc <= 1) { - Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs"); - return (TCL_ERROR); - } - if (dbc == NULL) { - Tcl_SetResult(interp, "NULL dbc pointer", TCL_STATIC); - return (TCL_ERROR); - } - if (dbip == NULL) { - Tcl_SetResult(interp, "NULL dbc info pointer", TCL_STATIC); - return (TCL_ERROR); - } - - /* - * Get the command name index from the object based on the berkdbcmds - * defined above. - */ - if (Tcl_GetIndexFromObj(interp, objv[1], dbccmds, "command", - TCL_EXACT, &cmdindex) != TCL_OK) - return (IS_HELP(objv[1])); - switch ((enum dbccmds)cmdindex) { -#if 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->c_close(dbc); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "dbc close"); - if (result == TCL_OK) { - (void)Tcl_DeleteCommand(interp, dbip->i_name); - _DeleteInfo(dbip); - } - break; - case DBCDELETE: - /* - * No args for this. Error if there are some. - */ - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return (TCL_ERROR); - } - _debug_check(); - ret = dbc->c_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 char *dbcutopts[] = { -#if CONFIG_TEST - "-nodupdata", -#endif - "-after", - "-before", - "-current", - "-keyfirst", - "-keylast", - "-partial", - NULL - }; - enum dbcutopts { -#if CONFIG_TEST - DBCPUT_NODUPDATA, -#endif - DBCPUT_AFTER, - DBCPUT_BEFORE, - DBCPUT_CURRENT, - DBCPUT_KEYFIRST, - DBCPUT_KEYLAST, - DBCPUT_PART - }; - DB *thisdbp; - DBT key, data; - DBTCL_INFO *dbcip, *dbip; - DBTYPE type; - Tcl_Obj **elemv, *res; - void *dtmp, *ktmp; - db_recno_t recno; - u_int32_t flag; - int elemc, freekey, freedata, i, optindex, result, ret; - - 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) { -#if CONFIG_TEST - case DBCPUT_NODUPDATA: - FLAG_CHECK(flag); - flag = DB_NODUPDATA; - break; -#endif - case DBCPUT_AFTER: - FLAG_CHECK(flag); - flag = DB_AFTER; - break; - case DBCPUT_BEFORE: - FLAG_CHECK(flag); - flag = DB_BEFORE; - break; - case DBCPUT_CURRENT: - FLAG_CHECK(flag); - flag = DB_CURRENT; - break; - case DBCPUT_KEYFIRST: - FLAG_CHECK(flag); - flag = DB_KEYFIRST; - break; - case DBCPUT_KEYLAST: - FLAG_CHECK(flag); - flag = DB_KEYLAST; - break; - case DBCPUT_PART: - if (i > (objc - 2)) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-partial {offset length}?"); - result = TCL_ERROR; - break; - } - /* - * Get sublist as {offset length} - */ - result = Tcl_ListObjGetElements(interp, objv[i++], - &elemc, &elemv); - if (elemc != 2) { - Tcl_SetResult(interp, - "List must be {offset length}", TCL_STATIC); - result = TCL_ERROR; - break; - } - data.flags |= DB_DBT_PARTIAL; - result = _GetUInt32(interp, elemv[0], &data.doff); - if (result != TCL_OK) - break; - result = _GetUInt32(interp, elemv[1], &data.dlen); - /* - * NOTE: We don't check result here because all we'd - * do is break anyway, and we are doing that. If you - * add code here, you WILL need to add the check - * for result. (See the check for save.doff, a few - * lines above and copy that.) - */ - } - if (result != TCL_OK) - break; - } - if (result != TCL_OK) - goto out; - - /* - * We need to determine if we are a recno database or not. If we are, - * then key.data is a recno, not a string. - */ - dbcip = _PtrToInfo(dbc); - if (dbcip == NULL) - type = DB_UNKNOWN; - else { - dbip = dbcip->i_parent; - if (dbip == NULL) { - Tcl_SetResult(interp, "Cursor without parent database", - TCL_STATIC); - result = TCL_ERROR; - return (result); - } - thisdbp = dbip->i_dbp; - (void)thisdbp->get_type(thisdbp, &type); - } - /* - * When we get here, we better have: - * 1 arg if -after, -before or -current - * 2 args in all other cases - */ - if (flag == DB_AFTER || flag == DB_BEFORE || flag == DB_CURRENT) { - if (i != (objc - 1)) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-args? data"); - result = TCL_ERROR; - goto out; - } - /* - * We want to get the key back, so we need to set - * up the location to get it back in. - */ - if (type == DB_RECNO || type == DB_QUEUE) { - recno = 0; - key.data = &recno; - key.size = sizeof(db_recno_t); - } - } else { - if (i != (objc - 2)) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-args? key data"); - result = TCL_ERROR; - goto out; - } - if (type == DB_RECNO || type == DB_QUEUE) { - result = _GetUInt32(interp, objv[objc-2], &recno); - if (result == TCL_OK) { - key.data = &recno; - key.size = sizeof(db_recno_t); - } else - return (result); - } else { - ret = _CopyObjBytes(interp, objv[objc-2], &ktmp, - &key.size, &freekey); - if (ret != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_DBCPUT(ret), "dbc put"); - return (result); - } - key.data = ktmp; - } - } - ret = _CopyObjBytes(interp, objv[objc-1], &dtmp, - &data.size, &freedata); - data.data = dtmp; - if (ret != 0) { - result = _ReturnSetup(interp, ret, - DB_RETOK_DBCPUT(ret), "dbc put"); - goto out; - } - _debug_check(); - ret = dbc->c_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_NewLongObj((long)*(db_recno_t *)key.data); - Tcl_SetObjResult(interp, res); - } -out: - if (freedata) - (void)__os_free(NULL, dtmp); - if (freekey) - (void)__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 char *dbcgetopts[] = { -#if CONFIG_TEST - "-dirty", - "-get_both_range", - "-multi", - "-multi_key", -#endif - "-current", - "-first", - "-get_both", - "-get_recno", - "-join_item", - "-last", - "-next", - "-nextdup", - "-nextnodup", - "-partial", - "-prev", - "-prevnodup", - "-rmw", - "-set", - "-set_range", - "-set_recno", - NULL - }; - enum dbcgetopts { -#if CONFIG_TEST - DBCGET_DIRTY, - DBCGET_BOTH_RANGE, - DBCGET_MULTI, - DBCGET_MULTI_KEY, -#endif - DBCGET_CURRENT, - DBCGET_FIRST, - DBCGET_BOTH, - DBCGET_RECNO, - DBCGET_JOIN, - DBCGET_LAST, - DBCGET_NEXT, - DBCGET_NEXTDUP, - DBCGET_NEXTNODUP, - DBCGET_PART, - DBCGET_PREV, - 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 bufsize, elemc, freekey, freedata, i, optindex, result, ret; - - 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) { - 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++; - switch ((enum dbcgetopts)optindex) { -#if CONFIG_TEST - case DBCGET_DIRTY: - flag |= DB_DIRTY_READ; - break; - case DBCGET_BOTH_RANGE: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_GET_BOTH_RANGE; - break; - case DBCGET_MULTI: - flag |= DB_MULTIPLE; - result = Tcl_GetIntFromObj(interp, objv[i], &bufsize); - if (result != TCL_OK) - goto out; - i++; - break; - case DBCGET_MULTI_KEY: - flag |= DB_MULTIPLE_KEY; - result = Tcl_GetIntFromObj(interp, objv[i], &bufsize); - if (result != TCL_OK) - goto out; - i++; - break; -#endif - case DBCGET_RMW: - flag |= DB_RMW; - break; - case DBCGET_CURRENT: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_CURRENT; - break; - case DBCGET_FIRST: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_FIRST; - break; - case DBCGET_LAST: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_LAST; - break; - case DBCGET_NEXT: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_NEXT; - break; - case DBCGET_PREV: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_PREV; - break; - case DBCGET_PREVNODUP: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_PREV_NODUP; - break; - case DBCGET_NEXTNODUP: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_NEXT_NODUP; - break; - case DBCGET_NEXTDUP: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_NEXT_DUP; - break; - case DBCGET_BOTH: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_GET_BOTH; - break; - case DBCGET_RECNO: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_GET_RECNO; - break; - case DBCGET_JOIN: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_JOIN_ITEM; - break; - case DBCGET_SET: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_SET; - break; - case DBCGET_SETRANGE: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - flag |= DB_SET_RANGE; - break; - case DBCGET_SETRECNO: - FLAG_CHECK2(flag, - DB_RMW|DB_MULTIPLE|DB_MULTIPLE_KEY|DB_DIRTY_READ); - 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: -#if 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; - } - if (flag & (DB_MULTIPLE|DB_MULTIPLE_KEY)) { - (void)__os_malloc(NULL, bufsize, &data.data); - data.ulen = bufsize; - data.flags |= DB_DBT_USERMEM; - } else - 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; - } - key.flags |= DB_DBT_MALLOC; - if (flag & (DB_MULTIPLE|DB_MULTIPLE_KEY)) { - (void)__os_malloc(NULL, bufsize, &data.data); - data.ulen = bufsize; - data.flags |= DB_DBT_USERMEM; - } else - data.flags |= DB_DBT_MALLOC; - } - - _debug_check(); - memset(&pdata, 0, sizeof(DBT)); - if (ispget) { - F_SET(&pdata, DB_DBT_MALLOC); - ret = dbc->c_pget(dbc, &key, &data, &pdata, flag); - } else - ret = dbc->c_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 == DB_NOTFOUND) - goto out1; - if (op == DB_GET_RECNO) { - recno = *((db_recno_t *)data.data); - myobj = Tcl_NewLongObj((long)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); - } - } - if (key.data != NULL && F_ISSET(&key, DB_DBT_MALLOC)) - __os_ufree(dbc->dbp->dbenv, key.data); - if (data.data != NULL && F_ISSET(&data, DB_DBT_MALLOC)) - __os_ufree(dbc->dbp->dbenv, data.data); - if (pdata.data != NULL && F_ISSET(&pdata, DB_DBT_MALLOC)) - __os_ufree(dbc->dbp->dbenv, pdata.data); -out1: - if (result == TCL_OK) - Tcl_SetObjResult(interp, retlist); -out: - if (data.data != NULL && flag & (DB_MULTIPLE|DB_MULTIPLE_KEY)) - __os_free(dbc->dbp->dbenv, data.data); - if (freedata) - (void)__os_free(NULL, dtmp); - if (freekey) - (void)__os_free(NULL, ktmp); - return (result); - -} - -/* - * tcl_DbcDup -- - */ -static int -tcl_DbcDup(interp, objc, objv, dbc) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DBC *dbc; /* Cursor pointer */ -{ - static 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->c_dup(dbc, &newdbc, flag); - if (ret == 0) { - dbip->i_dbdbcid++; - newdbcip->i_parent = dbip; - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)dbc_Cmd, - (ClientData)newdbc, NULL); - res = Tcl_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/bdb/tcl/tcl_env.c b/bdb/tcl/tcl_env.c deleted file mode 100644 index cdf4890e9fc..00000000000 --- a/bdb/tcl/tcl_env.c +++ /dev/null @@ -1,1310 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2002 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_env.c,v 11.84 2002/08/06 06:21:03 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.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 *)); - -/* - * 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 char *envcmds[] = { -#if CONFIG_TEST - "attributes", - "lock_detect", - "lock_id", - "lock_id_free", - "lock_id_set", - "lock_get", - "lock_stat", - "lock_timeout", - "lock_vec", - "log_archive", - "log_compare", - "log_cursor", - "log_file", - "log_flush", - "log_get", - "log_put", - "log_stat", - "mpool", - "mpool_stat", - "mpool_sync", - "mpool_trickle", - "mutex", - "rep_elect", - "rep_flush", - "rep_limit", - "rep_process_message", - "rep_request", - "rep_start", - "rep_stat", - "rpcid", - "test", - "txn_checkpoint", - "txn_id_set", - "txn_recover", - "txn_stat", - "txn_timeout", - "verbose", -#endif - "close", - "dbremove", - "dbrename", - "txn", - NULL - }; - enum envcmds { -#if CONFIG_TEST - ENVATTR, - ENVLKDETECT, - ENVLKID, - ENVLKFREEID, - ENVLKSETID, - ENVLKGET, - ENVLKSTAT, - ENVLKTIMEOUT, - ENVLKVEC, - ENVLOGARCH, - ENVLOGCMP, - ENVLOGCURSOR, - ENVLOGFILE, - ENVLOGFLUSH, - ENVLOGGET, - ENVLOGPUT, - ENVLOGSTAT, - ENVMP, - ENVMPSTAT, - ENVMPSYNC, - ENVTRICKLE, - ENVMUTEX, - ENVREPELECT, - ENVREPFLUSH, - ENVREPLIMIT, - ENVREPPROCMESS, - ENVREPREQUEST, - ENVREPSTART, - ENVREPSTAT, - ENVRPCID, - ENVTEST, - ENVTXNCKP, - ENVTXNSETID, - ENVTXNRECOVER, - ENVTXNSTAT, - ENVTXNTIMEOUT, - ENVVERB, -#endif - ENVCLOSE, - ENVDBREMOVE, - ENVDBRENAME, - ENVTXN - }; - DBTCL_INFO *envip, *logcip; - DB_ENV *dbenv; - DB_LOGC *logc; - Tcl_Obj *res; - char newname[MSG_SIZE]; - int cmdindex, result, ret; - u_int32_t newval; -#if CONFIG_TEST - u_int32_t 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) { -#if CONFIG_TEST - 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, &newval); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "lock_id"); - if (result == TCL_OK) - res = Tcl_NewLongObj((long)newval); - break; - case ENVLKFREEID: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 3, objv, NULL); - return (TCL_ERROR); - } - result = Tcl_GetLongFromObj(interp, objv[2], (long *)&newval); - if (result != TCL_OK) - return (result); - ret = dbenv->lock_id_free(dbenv, 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], (long *)&newval); - if (result != TCL_OK) - return (result); - result = Tcl_GetLongFromObj(interp, objv[3], (long *)&otherval); - if (result != TCL_OK) - return (result); - ret = dbenv->lock_id_set(dbenv, newval, 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 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. - */ - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)logc_Cmd, - (ClientData)logc, NULL); - res = - Tcl_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 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 ENVREPELECT: - result = tcl_RepElect(interp, objc, objv, dbenv); - break; - case ENVREPFLUSH: - result = tcl_RepFlush(interp, objc, objv, 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 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 dbp-private data. - */ - res = Tcl_NewLongObj(dbenv->cl_id); - break; - case ENVTXNCKP: - result = tcl_TxnCheckpoint(interp, objc, objv, dbenv); - break; - case ENVTXNSETID: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 4, objv, "current max"); - return (TCL_ERROR); - } - result = Tcl_GetLongFromObj(interp, objv[2], (long *)&newval); - if (result != TCL_OK) - return (result); - result = Tcl_GetLongFromObj(interp, objv[3], (long *)&otherval); - if (result != TCL_OK) - return (result); - ret = dbenv->txn_id_set(dbenv, newval, otherval); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "lock id_free"); - 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 ENVMUTEX: - result = tcl_Mutex(interp, objc, objv, dbenv, envip); - break; - case ENVATTR: - result = tcl_EnvAttr(interp, objc, objv, dbenv); - 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 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 ENVTXN: - result = tcl_Txn(interp, objc, objv, dbenv, envip); - 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 char *envremopts[] = { -#if CONFIG_TEST - "-overwrite", - "-server", -#endif - "-data_dir", - "-encryptaes", - "-encryptany", - "-force", - "-home", - "-log_dir", - "-tmp_dir", - "-use_environ", - "-use_environ_root", - NULL - }; - enum envremopts { -#if 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 - }; - DB_ENV *e; - 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) { -#if 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_CLIENT; - 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; -#if 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(&e, cflag)) != 0) { - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "db_env_create"); - goto error; - } - if (server != NULL) { - _debug_check(); - ret = e->set_rpc_server(e, 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 = e->set_data_dir(e, datadir); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_data_dir"); - if (result != TCL_OK) - goto error; - } - if (logdir != NULL) { - _debug_check(); - ret = e->set_lg_dir(e, logdir); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_log_dir"); - if (result != TCL_OK) - goto error; - } - if (tmpdir != NULL) { - _debug_check(); - ret = e->set_tmp_dir(e, tmpdir); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_tmp_dir"); - if (result != TCL_OK) - goto error; - } - if (passwd != NULL) { - ret = e->set_encrypt(e, passwd, enc_flag); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_encrypt"); - } - if (sflag != 0 && (ret = e->set_flags(e, sflag, 1)) != 0) { - _debug_check(); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "set_flags"); - if (result != TCL_OK) - goto error; - } - } 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; - e = dbenv; - } - - flag |= forceflag; - /* - * When we get here we have parsed all the args. Now remove - * the environment. - */ - _debug_check(); - ret = e->remove(e, 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; - default: - 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); -} - -#if CONFIG_TEST -/* - * 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 char *verbwhich[] = { - "chkpt", - "deadlock", - "recovery", - "rep", - "wait", - NULL - }; - enum verbwhich { - ENVVERB_CHK, - ENVVERB_DEAD, - ENVVERB_REC, - ENVVERB_REP, - ENVVERB_WAIT - }; - static 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_CHK: - wh = DB_VERB_CHKPOINT; - break; - case ENVVERB_DEAD: - wh = DB_VERB_DEADLOCK; - break; - case ENVVERB_REC: - wh = DB_VERB_RECOVERY; - break; - case ENVVERB_REP: - wh = DB_VERB_REPLICATION; - break; - case ENVVERB_WAIT: - 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 - -#if 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 */ -{ - int result; - Tcl_Obj *myobj, *retlist; - - 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 dbenv to determine what subsystems - * we have available in this env. - */ - myobj = Tcl_NewStringObj("-home", strlen("-home")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - myobj = Tcl_NewStringObj(dbenv->db_home, strlen(dbenv->db_home)); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - if (CDB_LOCKING(dbenv)) { - myobj = Tcl_NewStringObj("-cdb", strlen("-cdb")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (CRYPTO_ON(dbenv)) { - myobj = Tcl_NewStringObj("-crypto", strlen("-crypto")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (LOCKING_ON(dbenv)) { - myobj = Tcl_NewStringObj("-lock", strlen("-lock")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (LOGGING_ON(dbenv)) { - myobj = Tcl_NewStringObj("-log", strlen("-log")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (MPOOL_ON(dbenv)) { - myobj = Tcl_NewStringObj("-mpool", strlen("-mpool")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (RPC_ON(dbenv)) { - myobj = Tcl_NewStringObj("-rpc", strlen("-rpc")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - if (TXN_ON(dbenv)) { - myobj = Tcl_NewStringObj("-txn", strlen("-txn")); - if ((result = Tcl_ListObjAppendElement(interp, - retlist, myobj)) != TCL_OK) - goto err; - } - Tcl_SetObjResult(interp, retlist); -err: - return (result); -} - -/* - * PUBLIC: int tcl_EnvTest __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); - * - * tcl_EnvTest -- - */ -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 char *envtestcmd[] = { - "abort", - "copy", - NULL - }; - enum envtestcmd { - ENVTEST_ABORT, - ENVTEST_COPY - }; - static char *envtestat[] = { - "electinit", - "electsend", - "electvote1", - "electvote2", - "electwait1", - "electwait2", - "none", - "predestroy", - "preopen", - "postdestroy", - "postlog", - "postlogmeta", - "postopen", - "postsync", - "subdb_lock", - NULL - }; - enum envtestat { - ENVTEST_ELECTINIT, - ENVTEST_ELECTSEND, - ENVTEST_ELECTVOTE1, - ENVTEST_ELECTVOTE2, - ENVTEST_ELECTWAIT1, - ENVTEST_ELECTWAIT2, - ENVTEST_NONE, - ENVTEST_PREDESTROY, - ENVTEST_PREOPEN, - ENVTEST_POSTDESTROY, - ENVTEST_POSTLOG, - ENVTEST_POSTLOGMETA, - ENVTEST_POSTOPEN, - ENVTEST_POSTSYNC, - ENVTEST_SUBDB_LOCKS - }; - int *loc, optindex, result, testval; - - result = TCL_OK; - loc = NULL; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "abort|copy location"); - return (TCL_ERROR); - } - - /* - * This must be the "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 = &dbenv->test_abort; - break; - case ENVTEST_COPY: - loc = &dbenv->test_copy; - break; - 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(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTINIT; - break; - case ENVTEST_ELECTSEND: - DB_ASSERT(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTSEND; - break; - case ENVTEST_ELECTVOTE1: - DB_ASSERT(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTVOTE1; - break; - case ENVTEST_ELECTVOTE2: - DB_ASSERT(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTVOTE2; - break; - case ENVTEST_ELECTWAIT1: - DB_ASSERT(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTWAIT1; - break; - case ENVTEST_ELECTWAIT2: - DB_ASSERT(loc == &dbenv->test_abort); - testval = DB_TEST_ELECTWAIT2; - 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(loc == &dbenv->test_abort); - testval = DB_TEST_SUBDB_LOCKS; - break; - default: - Tcl_SetResult(interp, "Illegal test location", TCL_STATIC); - return (TCL_ERROR); - } - - *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 char *envdbrem[] = { - "-auto_commit", - "-txn", - "--", - NULL - }; - enum envdbrem { - TCL_EDBREM_COMMIT, - 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; - } - /* - * 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 (i != objc) { - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &subdblen); - if ((ret = __os_malloc(dbenv, subdblen + 1, - &subdb)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(subdb, subdbtmp, 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, 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 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 (i == objc - 2) { - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &subdblen); - if ((ret = __os_malloc(dbenv, subdblen + 1, - &subdb)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(subdb, subdbtmp, subdblen); - subdb[subdblen] = '\0'; - } - subdbtmp = - Tcl_GetByteArrayFromObj(objv[i++], &newlen); - if ((ret = __os_malloc(dbenv, newlen + 1, - &newname)) != 0) { - Tcl_SetResult(interp, - db_strerror(ret), TCL_STATIC); - return (0); - } - memcpy(newname, subdbtmp, 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, subdb); - if (newname) - __os_free(dbenv, newname); - return (result); -} diff --git a/bdb/tcl/tcl_internal.c b/bdb/tcl/tcl_internal.c deleted file mode 100644 index 2d6ad4df444..00000000000 --- a/bdb/tcl/tcl_internal.c +++ /dev/null @@ -1,717 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_internal.c,v 11.54 2002/08/15 02:47:46 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" -#include "dbinc/db_page.h" -#include "dbinc/db_am.h" -#include "dbinc_auto/db_ext.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. - */ - -/* - * Prototypes for procedures defined later in this file: - */ -static void tcl_flag_callback __P((u_int32_t, const FN *, void *)); - -/* - * Private structure type used to pass both an interp and an object into - * a callback's single void *. - */ -struct __tcl_callback_bundle { - Tcl_Interp *interp; - Tcl_Obj *obj; -}; - -#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 i, ret; - - if ((ret = __os_malloc(NULL, sizeof(DBTCL_INFO), &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_data = 0; - p->i_data2 = 0; - p->i_type = type; - p->i_parent = NULL; - p->i_err = NULL; - p->i_errpfx = NULL; - p->i_lockobj.data = NULL; - p->i_btcompare = NULL; - p->i_dupcompare = NULL; - p->i_hashproc = NULL; - p->i_second_call = NULL; - p->i_rep_eid = NULL; - p->i_rep_send = NULL; - for (i = 0; i < MAX_ID; i++) - p->i_otherid[i] = 0; - - LIST_INSERT_HEAD(&__db_infohead, p, entries); - return (p); -} - -/* - * PUBLIC: void *_NameToPtr __P((CONST char *)); - */ -void * -_NameToPtr(name) - CONST char *name; -{ - DBTCL_INFO *p; - - for (p = LIST_FIRST(&__db_infohead); p != NULL; - p = LIST_NEXT(p, 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; - - for (p = LIST_FIRST(&__db_infohead); p != NULL; - p = LIST_NEXT(p, 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; - - for (p = LIST_FIRST(&__db_infohead); p != NULL; - p = LIST_NEXT(p, 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) { - fclose(p->i_err); - p->i_err = NULL; - } - if (p->i_errpfx != NULL) - __os_free(NULL, p->i_errpfx); - if (p->i_btcompare != NULL) - Tcl_DecrRefCount(p->i_btcompare); - if (p->i_dupcompare != NULL) - Tcl_DecrRefCount(p->i_dupcompare); - if (p->i_hashproc != NULL) - Tcl_DecrRefCount(p->i_hashproc); - if (p->i_second_call != NULL) - Tcl_DecrRefCount(p->i_second_call); - if (p->i_rep_eid != NULL) - Tcl_DecrRefCount(p->i_rep_eid); - if (p->i_rep_send != NULL) - Tcl_DecrRefCount(p->i_rep_send); - __os_free(NULL, p->i_name); - __os_free(NULL, p); - - return; -} - -/* - * PUBLIC: int _SetListElem __P((Tcl_Interp *, - * PUBLIC: Tcl_Obj *, void *, int, void *, int)); - */ -int -_SetListElem(interp, list, elem1, e1cnt, elem2, e2cnt) - Tcl_Interp *interp; - Tcl_Obj *list; - void *elem1, *elem2; - int e1cnt, e2cnt; -{ - Tcl_Obj *myobjv[2], *thislist; - int myobjc; - - myobjc = 2; - myobjv[0] = Tcl_NewByteArrayObj((u_char *)elem1, e1cnt); - myobjv[1] = Tcl_NewByteArrayObj((u_char *)elem2, 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 *, int)); - */ -int -_SetListElemInt(interp, list, elem1, elem2) - Tcl_Interp *interp; - Tcl_Obj *list; - void *elem1; - int elem2; -{ - Tcl_Obj *myobjv[2], *thislist; - int myobjc; - - myobjc = 2; - myobjv[0] = Tcl_NewByteArrayObj((u_char *)elem1, strlen((char *)elem1)); - myobjv[1] = Tcl_NewIntObj(elem2); - thislist = Tcl_NewListObj(myobjc, myobjv); - if (thislist == NULL) - return (TCL_ERROR); - return (Tcl_ListObjAppendElement(interp, list, thislist)); -} - -/* - * PUBLIC: int _SetListRecnoElem __P((Tcl_Interp *, Tcl_Obj *, - * PUBLIC: db_recno_t, u_char *, int)); - */ -int -_SetListRecnoElem(interp, list, elem1, elem2, e2size) - Tcl_Interp *interp; - Tcl_Obj *list; - db_recno_t elem1; - u_char *elem2; - int e2size; -{ - Tcl_Obj *myobjv[2], *thislist; - int myobjc; - - myobjc = 2; - myobjv[0] = Tcl_NewLongObj((long)elem1); - myobjv[1] = Tcl_NewByteArrayObj(elem2, 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_NewLongObj((long)*(db_recno_t *)elem1->data); - else - myobjv[0] = - Tcl_NewByteArrayObj((u_char *)elem1->data, elem1->size); - - if (is2recno) - myobjv[1] = Tcl_NewLongObj((long)*(db_recno_t *)elem2->data); - else - myobjv[1] = - Tcl_NewByteArrayObj((u_char *)elem2->data, elem2->size); - - myobjv[2] = Tcl_NewByteArrayObj((u_char *)elem3->data, 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*, int, int)); - */ -int -_SetMultiList(interp, list, key, data, type, flag) - Tcl_Interp *interp; - Tcl_Obj *list; - DBT *key, *data; - int type, 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++; - } 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 char *, char *)); - */ -void -_ErrorFunc(pfx, msg) - CONST char *pfx; - char *msg; -{ - DBTCL_INFO *p; - Tcl_Interp *interp; - int size; - char *err; - - 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; -} - -#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); -} - -/* - * tcl_flag_callback -- - * Callback for db_pr.c functions that contain the FN struct mapping - * flag values to meaningful strings. This function appends a Tcl_Obj - * containing each pertinent flag string to the specified Tcl list. - */ -static void -tcl_flag_callback(flags, fn, vtcbp) - u_int32_t flags; - const FN *fn; - void *vtcbp; -{ - const FN *fnp; - Tcl_Interp *interp; - Tcl_Obj *newobj, *listobj; - int result; - struct __tcl_callback_bundle *tcbp; - - tcbp = (struct __tcl_callback_bundle *)vtcbp; - interp = tcbp->interp; - listobj = tcbp->obj; - - for (fnp = fn; fnp->mask != 0; ++fnp) - if (LF_ISSET(fnp->mask)) { - newobj = Tcl_NewStringObj(fnp->name, strlen(fnp->name)); - result = - Tcl_ListObjAppendElement(interp, listobj, newobj); - - /* - * Tcl_ListObjAppendElement is defined to return TCL_OK - * unless listobj isn't actually a list (or convertible - * into one). If this is the case, we screwed up badly - * somehow. - */ - DB_ASSERT(result == TCL_OK); - } -} - -/* - * _GetFlagsList -- - * Get a new Tcl object, containing a list of the string values - * associated with a particular set of flag values, given a function - * that can extract the right names for the right flags. - * - * PUBLIC: Tcl_Obj *_GetFlagsList __P((Tcl_Interp *, u_int32_t, - * PUBLIC: void (*)(u_int32_t, void *, - * PUBLIC: void (*)(u_int32_t, const FN *, void *)))); - */ -Tcl_Obj * -_GetFlagsList(interp, flags, func) - Tcl_Interp *interp; - u_int32_t flags; - void (*func) - __P((u_int32_t, void *, void (*)(u_int32_t, const FN *, void *))); -{ - Tcl_Obj *newlist; - struct __tcl_callback_bundle tcb; - - newlist = Tcl_NewObj(); - - memset(&tcb, 0, sizeof(tcb)); - tcb.interp = interp; - tcb.obj = newlist; - - func(flags, &tcb, tcl_flag_callback); - - 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); - 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 = len; - if (ret == TCL_ERROR) { - Tcl_ResetResult(interp); - *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, len, &new)) != 0) - return (ret); - memcpy(new, tmp, len); - *newp = new; - *freep = 1; - return (0); -} diff --git a/bdb/tcl/tcl_lock.c b/bdb/tcl/tcl_lock.c deleted file mode 100644 index 6cb96dbb0da..00000000000 --- a/bdb/tcl/tcl_lock.c +++ /dev/null @@ -1,739 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_lock.c,v 11.47 2002/08/08 15:27:10 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" - -/* - * Prototypes for procedures defined later in this file: - */ -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 *)); -#if CONFIG_TEST -static char *lkmode[] = { - "ng", - "read", - "write", - "iwrite", - "iread", - "iwr", - NULL -}; -enum lkmode { - LK_NG, - LK_READ, - LK_WRITE, - LK_IWRITE, - LK_IREAD, - LK_IWR -}; - -/* - * tcl_LockDetect -- - * - * PUBLIC: int tcl_LockDetect __P((Tcl_Interp *, int, - * PUBLIC: Tcl_Obj * CONST*, DB_ENV *)); - */ -int -tcl_LockDetect(interp, objc, objv, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - static char *ldopts[] = { - "expire", - "default", - "maxlocks", - "minlocks", - "minwrites", - "oldest", - "random", - "youngest", - NULL - }; - enum ldopts { - LD_EXPIRE, - LD_DEFAULT, - LD_MAXLOCKS, - 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_EXPIRE: - FLAG_CHECK(policy); - policy = DB_LOCK_EXPIRE; - break; - case LD_DEFAULT: - FLAG_CHECK(policy); - policy = DB_LOCK_DEFAULT; - break; - case LD_MAXLOCKS: - FLAG_CHECK(policy); - policy = DB_LOCK_MAXLOCKS; - break; - case LD_MINWRITES: - FLAG_CHECK(policy); - policy = DB_LOCK_MINWRITE; - break; - case LD_MINLOCKS: - FLAG_CHECK(policy); - policy = DB_LOCK_MINLOCKS; - break; - case LD_OLDEST: - FLAG_CHECK(policy); - policy = DB_LOCK_OLDEST; - break; - case LD_YOUNGEST: - FLAG_CHECK(policy); - policy = DB_LOCK_YOUNGEST; - break; - case LD_RANDOM: - FLAG_CHECK(policy); - policy = DB_LOCK_RANDOM; - break; - } - } - - _debug_check(); - ret = envp->lock_detect(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - static 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, envp, lockid, flag, &obj, mode, newname); - if (result == TCL_OK) { - res = Tcl_NewStringObj(newname, strlen(newname)); - Tcl_SetObjResult(interp, res); - } -out: - if (freeobj) - (void)__os_free(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->lock_stat(envp, &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(); - /* - * 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("Current number of locks", sp->st_nlocks); - MAKE_STAT_LIST("Maximum number of locks so far", sp->st_maxnlocks); - 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("Number of conflicts", sp->st_nconflicts); - MAKE_STAT_LIST("Lock requests", sp->st_nrequests); - MAKE_STAT_LIST("Lock releases", sp->st_nreleases); - MAKE_STAT_LIST("Lock requests that would have waited", sp->st_nnowaits); - MAKE_STAT_LIST("Deadlocks detected", sp->st_ndeadlocks); - MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait); - MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait); - MAKE_STAT_LIST("Lock timeout value", sp->st_locktimeout); - MAKE_STAT_LIST("Number of lock timeouts", sp->st_nlocktimeouts); - MAKE_STAT_LIST("Transaction timeout value", sp->st_txntimeout); - MAKE_STAT_LIST("Number of transaction timeouts", sp->st_ntxntimeouts); - Tcl_SetObjResult(interp, res); -error: - free(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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->set_timeout(envp, (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 char *lkcmds[] = { - "put", - NULL - }; - enum lkcmds { - LKPUT - }; - DB_ENV *env; - 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); - } - - env = 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 = env->lock_put(env, lock); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "lock put"); - (void)Tcl_DeleteCommand(interp, lkip->i_name); - _DeleteInfo(lkip); - __os_free(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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* environment pointer */ -{ - static char *lvopts[] = { - "-nowait", - NULL - }; - enum lvopts { - LVNOWAIT - }; - static 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); - flag = 0; - freeobj = 0; - - /* - * 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, envp, 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 = Tcl_NewStringObj(newname, strlen(newname)); - (void)Tcl_ListObjAppendElement(interp, res, thisop); - if (freeobj) { - (void)__os_free(envp, 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 = envp->lock_vec(envp, 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) { - (void)__os_free(envp, 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; -{ - 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, envp, lockid, flag, objp, mode, newname) - Tcl_Interp *interp; /* Interpreter */ - DB_ENV *envp; /* 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 */ -{ - DB_LOCK *lock; - DBTCL_INFO *envip, *ip; - int result, ret; - - result = TCL_OK; - envip = _PtrToInfo((void *)envp); - 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(envp, sizeof(DB_LOCK), &lock); - if (ret != 0) { - Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); - return (TCL_ERROR); - } - _debug_check(); - ret = envp->lock_get(envp, lockid, flag, objp, mode, lock); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock get"); - if (result == TCL_ERROR) { - __os_free(envp, lock); - _DeleteInfo(ip); - return (result); - } - /* - * Success. Set up return. Set up new info - * and command widget for this lock. - */ - ret = __os_malloc(envp, objp->size, &ip->i_lockobj.data); - if (ret != 0) { - Tcl_SetResult(interp, "Could not duplicate obj", - TCL_STATIC); - (void)envp->lock_put(envp, lock); - __os_free(envp, 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); - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)lock_Cmd, (ClientData)lock, NULL); -error: - return (result); -} -#endif diff --git a/bdb/tcl/tcl_log.c b/bdb/tcl/tcl_log.c deleted file mode 100644 index be6eebfb013..00000000000 --- a/bdb/tcl/tcl_log.c +++ /dev/null @@ -1,610 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2002 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_log.c,v 11.52 2002/08/14 20:11:57 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/log.h" -#include "dbinc/tcl_db.h" -#include "dbinc/txn.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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - static char *archopts[] = { - "-arch_abs", "-arch_data", "-arch_log", - NULL - }; - enum archopts { - ARCH_ABS, ARCH_DATA, ARCH_LOG - }; - 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; - } - } - _debug_check(); - list = NULL; - ret = envp->log_archive(envp, &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 = Tcl_NewStringObj(*file, strlen(*file)); - result = Tcl_ListObjAppendElement(interp, res, fileobj); - if (result != TCL_OK) - break; - } - Tcl_SetObjResult(interp, res); - } - if (list != NULL) - __os_ufree(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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(envp, name); - ret = __os_malloc(envp, len, &name); - if (ret != 0) { - Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); - break; - } - _debug_check(); - ret = envp->log_file(envp, &lsn, name, len); - len *= 2; - } - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "log_file"); - if (ret == 0) { - res = Tcl_NewStringObj(name, strlen(name)); - Tcl_SetObjResult(interp, res); - } - - if (name != NULL) - __os_free(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->log_flush(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - - COMPQUIET(objv, NULL); - COMPQUIET(objc, 0); - COMPQUIET(envp, 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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - static 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 = envp->log_put(envp, &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_NewLongObj((long)lsn.file); - result = Tcl_ListObjAppendElement(interp, res, intobj); - intobj = Tcl_NewLongObj((long)lsn.offset); - result = Tcl_ListObjAppendElement(interp, res, intobj); - Tcl_SetObjResult(interp, res); - if (freedata) - (void)__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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->log_stat(envp, &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. - */ - MAKE_STAT_LIST("Magic", sp->st_magic); - MAKE_STAT_LIST("Log file Version", sp->st_version); - MAKE_STAT_LIST("Region size", sp->st_regsize); - MAKE_STAT_LIST("Log file mode", sp->st_mode); - MAKE_STAT_LIST("Log record cache size", sp->st_lg_bsize); - MAKE_STAT_LIST("Current log file size", sp->st_lg_size); - MAKE_STAT_LIST("Mbytes written", sp->st_w_mbytes); - MAKE_STAT_LIST("Bytes written (over Mb)", sp->st_w_bytes); - MAKE_STAT_LIST("Mbytes written since checkpoint", sp->st_wc_mbytes); - MAKE_STAT_LIST("Bytes written (over Mb) since checkpoint", - sp->st_wc_bytes); - MAKE_STAT_LIST("Times log written", sp->st_wcount); - MAKE_STAT_LIST("Times log written because cache filled up", - sp->st_wcount_fill); - MAKE_STAT_LIST("Times log flushed", sp->st_scount); - MAKE_STAT_LIST("Current log file number", sp->st_cur_file); - MAKE_STAT_LIST("Current log file offset", sp->st_cur_offset); - MAKE_STAT_LIST("On-disk log file number", sp->st_disk_file); - MAKE_STAT_LIST("On-disk log file offset", sp->st_disk_offset); - MAKE_STAT_LIST("Max commits in a log flush", sp->st_maxcommitperflush); - MAKE_STAT_LIST("Min commits in a log flush", sp->st_mincommitperflush); - MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait); - MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait); - Tcl_SetObjResult(interp, res); -error: - free(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 char *logccmds[] = { - "close", - "get", - NULL - }; - enum logccmds { - LOGCCLOSE, - LOGCGET - }; - DB_LOGC *logc; - DBTCL_INFO *logcip; - 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; - } - return (result); -} - -static int -tcl_LogcGet(interp, objc, objv, logc) - Tcl_Interp *interp; - int objc; - Tcl_Obj * CONST *objv; - DB_LOGC *logc; -{ - static 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_NewLongObj((long)lsn.file); - myobjv[1] = Tcl_NewLongObj((long)lsn.offset); - lsnlist = Tcl_NewListObj(myobjc, myobjv); - if (lsnlist == NULL) - goto memerr; - - result = Tcl_ListObjAppendElement(interp, res, lsnlist); - dataobj = Tcl_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); -} -#endif diff --git a/bdb/tcl/tcl_mp.c b/bdb/tcl/tcl_mp.c deleted file mode 100644 index 0c4411cb58a..00000000000 --- a/bdb/tcl/tcl_mp.c +++ /dev/null @@ -1,864 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_mp.c,v 11.39 2002/08/06 06:21:27 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" - -/* - * Prototypes for procedures defined later in this file: - */ -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 *, int)); -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 *)); - -/* - * _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); - } - } -} - -#if CONFIG_TEST -/* - * tcl_MpSync -- - * - * PUBLIC: int tcl_MpSync __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); - */ -int -tcl_MpSync(interp, objc, objv, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->memp_sync(envp, lsnp); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp sync"); - return (result); -} - -/* - * tcl_MpTrickle -- - * - * PUBLIC: int tcl_MpTrickle __P((Tcl_Interp *, int, - * PUBLIC: Tcl_Obj * CONST*, DB_ENV *)); - */ -int -tcl_MpTrickle(interp, objc, objv, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - - int pages; - int percent; - int result; - int ret; - Tcl_Obj *res; - - 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 = envp->memp_trickle(envp, 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, envp, envip) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ - DBTCL_INFO *envip; /* Info pointer */ -{ - static char *mpopts[] = { - "-create", - "-mode", - "-nommap", - "-pagesize", - "-rdonly", - NULL - }; - enum mpopts { - MPCREATE, - MPMODE, - 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 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; - 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; - } - 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 = envp->memp_fcreate(envp, &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); - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)mp_Cmd, (ClientData)mpf, NULL); - res = Tcl_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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - DB_MPOOL_STAT *sp; - DB_MPOOL_FSTAT **fsp, **savefsp; - 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 = envp->memp_stat(envp, &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(); - /* - * 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("Region size", sp->st_regsize); - MAKE_STAT_LIST("Pages mapped into address space", sp->st_map); - MAKE_STAT_LIST("Cache hits", sp->st_cache_hit); - MAKE_STAT_LIST("Cache misses", sp->st_cache_miss); - MAKE_STAT_LIST("Pages created", sp->st_page_create); - MAKE_STAT_LIST("Pages read in", sp->st_page_in); - MAKE_STAT_LIST("Pages written", sp->st_page_out); - MAKE_STAT_LIST("Clean page evictions", sp->st_ro_evict); - MAKE_STAT_LIST("Dirty page evictions", sp->st_rw_evict); - MAKE_STAT_LIST("Dirty pages trickled", sp->st_page_trickle); - MAKE_STAT_LIST("Cached pages", sp->st_pages); - MAKE_STAT_LIST("Cached clean pages", sp->st_page_clean); - MAKE_STAT_LIST("Cached dirty pages", sp->st_page_dirty); - MAKE_STAT_LIST("Hash buckets", sp->st_hash_buckets); - MAKE_STAT_LIST("Hash lookups", sp->st_hash_searches); - MAKE_STAT_LIST("Longest hash chain found", sp->st_hash_longest); - MAKE_STAT_LIST("Hash elements examined", sp->st_hash_examined); - MAKE_STAT_LIST("Number of hash bucket nowaits", sp->st_hash_nowait); - MAKE_STAT_LIST("Number of hash bucket waits", sp->st_hash_wait); - MAKE_STAT_LIST("Maximum number of hash bucket waits", - sp->st_hash_max_wait); - MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait); - MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait); - MAKE_STAT_LIST("Page allocations", sp->st_alloc); - MAKE_STAT_LIST("Buckets examined during allocation", - sp->st_alloc_buckets); - MAKE_STAT_LIST("Maximum buckets examined during allocation", - sp->st_alloc_max_buckets); - MAKE_STAT_LIST("Pages examined during allocation", sp->st_alloc_pages); - MAKE_STAT_LIST("Maximum pages examined during allocation", - sp->st_alloc_max_pages); - - /* - * Save global stat list as res1. The MAKE_STAT_LIST - * macro assumes 'res' so we'll use that to build up - * our per-file sublist. - */ - res1 = res; - for (savefsp = fsp; fsp != NULL && *fsp != NULL; fsp++) { - res = Tcl_NewObj(); - result = _SetListElem(interp, res, "File Name", - strlen("File Name"), (*fsp)->file_name, - strlen((*fsp)->file_name)); - if (result != TCL_OK) - goto error; - MAKE_STAT_LIST("Page size", (*fsp)->st_pagesize); - MAKE_STAT_LIST("Pages mapped into address space", - (*fsp)->st_map); - MAKE_STAT_LIST("Cache hits", (*fsp)->st_cache_hit); - MAKE_STAT_LIST("Cache misses", (*fsp)->st_cache_miss); - MAKE_STAT_LIST("Pages created", (*fsp)->st_page_create); - MAKE_STAT_LIST("Pages read in", (*fsp)->st_page_in); - MAKE_STAT_LIST("Pages written", (*fsp)->st_page_out); - /* - * Now that we have a complete "per-file" stat list, append - * that to the other list. - */ - result = Tcl_ListObjAppendElement(interp, res1, res); - if (result != TCL_OK) - goto error; - } - Tcl_SetObjResult(interp, res1); -error: - free(sp); - if (savefsp != NULL) - free(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 char *mpcmds[] = { - "close", - "fsync", - "get", - NULL - }; - enum mpcmds { - MPCLOSE, - MPFSYNC, - MPGET - }; - DB_MPOOLFILE *mp; - int cmdindex, length, result, ret; - DBTCL_INFO *mpip; - Tcl_Obj *res; - char *obj_name; - - 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; - } - /* - * 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 char *mpget[] = { - "-create", - "-last", - "-new", - NULL - }; - enum mpget { - MPGET_CREATE, - MPGET_LAST, - MPGET_NEW - }; - - DBTCL_INFO *ip; - Tcl_Obj *res; - db_pgno_t pgno; - u_int32_t flag; - int i, ipgno, optindex, result, ret; - char newname[MSG_SIZE]; - void *page; - - 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_LAST: - flag |= DB_MPOOL_LAST; - break; - case MPGET_NEW: - flag |= DB_MPOOL_NEW; - 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 = ipgno; - ret = mp->get(mp, &pgno, 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); - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)pg_Cmd, (ClientData)page, NULL); - res = Tcl_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 char *pgcmds[] = { - "init", - "is_setto", - "pgnum", - "pgsize", - "put", - "set", - NULL - }; - enum pgcmds { - PGINIT, - PGISSET, - PGNUM, - PGSIZE, - PGPUT, - PGSET - }; - 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_NewLongObj((long)pgip->i_pgno); - break; - case PGSIZE: - res = Tcl_NewLongObj(pgip->i_pgsz); - break; - case PGSET: - case PGPUT: - result = tcl_Pg(interp, objc, objv, page, mp, pgip, - cmdindex == PGSET ? 0 : 1); - 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) - Tcl_SetObjResult(interp, res); - return (result); -} - -static int -tcl_Pg(interp, objc, objv, page, mp, pgip, putop) - 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 */ - int putop; /* Operation */ -{ - static char *pgopt[] = { - "-clean", - "-dirty", - "-discard", - NULL - }; - enum pgopt { - PGCLEAN, - PGDIRTY, - 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 PGCLEAN: - flag |= DB_MPOOL_CLEAN; - break; - case PGDIRTY: - flag |= DB_MPOOL_DIRTY; - break; - case PGDISCARD: - flag |= DB_MPOOL_DISCARD; - break; - } - } - - _debug_check(); - if (putop) - ret = mp->put(mp, page, flag); - else - ret = mp->set(mp, page, flag); - - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "page"); - - if (putop) { - (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; - size_t pgsz; - long *p, *endp, newval; - int length, 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) ? (size_t)length : pgsz); - result = TCL_OK; - } else { - p = (long *)page; - for (endp = p + (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; - size_t pgsz; - long *p, *endp, newval; - int length, 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) ? (size_t)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 + (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/bdb/tcl/tcl_rep.c b/bdb/tcl/tcl_rep.c deleted file mode 100644 index c72c9971338..00000000000 --- a/bdb/tcl/tcl_rep.c +++ /dev/null @@ -1,405 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2002 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_rep.c,v 11.85 2002/08/06 04:45:44 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" - -#if 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 eid, nsites, pri, result, ret; - u_int32_t timeout; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 5, objv, "nsites pri timeout"); - return (TCL_ERROR); - } - - if ((result = Tcl_GetIntFromObj(interp, objv[2], &nsites)) != TCL_OK) - return (result); - if ((result = Tcl_GetIntFromObj(interp, objv[3], &pri)) != TCL_OK) - return (result); - if ((result = _GetUInt32(interp, objv[4], &timeout)) != TCL_OK) - return (result); - - _debug_check(); - if ((ret = dbenv->rep_elect(dbenv, nsites, pri, timeout, &eid)) != 0) - return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "env rep_elect")); - - Tcl_SetObjResult(interp, Tcl_NewIntObj(eid)); - - return (TCL_OK); -} -#endif - -#if 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 -#if CONFIG_TEST -/* - * tcl_RepLimit -- - * Call DB_ENV->set_rep_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->set_rep_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 - -#if CONFIG_TEST -/* - * tcl_RepRequest -- - * Call DB_ENV->set_rep_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; - u_int32_t min, max; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 4, objv, "min max"); - return (TCL_ERROR); - } - - if ((result = _GetUInt32(interp, objv[2], &min)) != TCL_OK) - return (result); - if ((result = _GetUInt32(interp, objv[3], &max)) != TCL_OK) - return (result); - - _debug_check(); - if ((ret = dbenv->set_rep_request(dbenv, min, max)) != 0) - return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "env set_rep_request")); - - return (_ReturnSetup(interp, - ret, DB_RETOK_STD(ret), "env set_rep_request")); -} -#endif - -#if 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 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 - -#if 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; - Tcl_Obj *res; - void *ctmp, *rtmp; - int eid; - int freectl, freerec, 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); - result = _ReturnSetup(interp, ret, DB_RETOK_REPPMSG(ret), - "env rep_process_message"); - - /* - * If we have a new master, return its environment ID. - * - * XXX - * We should do something prettier to differentiate success - * from an env ID, and figure out how to represent HOLDELECTION. - */ - if (result == TCL_OK && ret == DB_REP_NEWMASTER) { - res = Tcl_NewIntObj(eid); - Tcl_SetObjResult(interp, res); - } -out: - if (freectl) - (void)__os_free(NULL, ctmp); - if (freerec) - (void)__os_free(NULL, rtmp); - - return (result); -} -#endif - -#if 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; - - result = TCL_OK; - flag = 0; - - 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(); - /* - * MAKE_STAT_* assumes 'res' and 'error' label. - */ - MAKE_STAT_LSN("Next LSN expected", &sp->st_next_lsn); - MAKE_STAT_LSN("First missed LSN", &sp->st_waiting_lsn); - 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("Duplicate log records received", sp->st_log_duplicated); - MAKE_STAT_LIST("Current log records queued", sp->st_log_queued); - MAKE_STAT_LIST("Maximum log records queued", sp->st_log_queued_max); - MAKE_STAT_LIST("Total log records queued", sp->st_log_queued_total); - MAKE_STAT_LIST("Log records received", sp->st_log_records); - MAKE_STAT_LIST("Log records requested", sp->st_log_requested); - MAKE_STAT_LIST("Master environment ID", sp->st_master); - MAKE_STAT_LIST("Master changes", sp->st_master_changes); - MAKE_STAT_LIST("Messages with bad generation number", - sp->st_msgs_badgen); - MAKE_STAT_LIST("Messages processed", sp->st_msgs_processed); - MAKE_STAT_LIST("Messages ignored for recovery", sp->st_msgs_recover); - MAKE_STAT_LIST("Message send failures", sp->st_msgs_send_failures); - MAKE_STAT_LIST("Messages sent", sp->st_msgs_sent); - MAKE_STAT_LIST("New site messages", sp->st_newsites); - MAKE_STAT_LIST("Transmission limited", sp->st_nthrottles); - MAKE_STAT_LIST("Outdated conditions", sp->st_outdated); - MAKE_STAT_LIST("Transactions applied", sp->st_txns_applied); - MAKE_STAT_LIST("Elections held", sp->st_elections); - MAKE_STAT_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 priority", sp->st_election_priority); - MAKE_STAT_LIST("Election tiebreaker", sp->st_election_tiebreaker); - MAKE_STAT_LIST("Election votes", sp->st_election_votes); - - Tcl_SetObjResult(interp, res); -error: - free(sp); - return (result); -} -#endif diff --git a/bdb/tcl/tcl_txn.c b/bdb/tcl/tcl_txn.c deleted file mode 100644 index b5fab637943..00000000000 --- a/bdb/tcl/tcl_txn.c +++ /dev/null @@ -1,657 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_txn.c,v 11.57 2002/08/06 06:21:36 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ -{ - static char *txnckpopts[] = { - "-kbyte", "-min", - NULL - }; - enum txnckpopts { - TXNCKP_KB, TXNCKP_MIN - }; - int i, kb, min, optindex, result, ret; - - result = TCL_OK; - 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_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 = envp->txn_checkpoint(envp, (u_int32_t)kb, (u_int32_t)min, 0); - 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, envp, envip) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ - DBTCL_INFO *envip; /* Info pointer */ -{ - static char *txnopts[] = { -#if CONFIG_TEST - "-dirty", - "-lock_timeout", - "-txn_timeout", -#endif - "-nosync", - "-nowait", - "-parent", - "-sync", - NULL - }; - enum txnopts { -#if CONFIG_TEST - TXNDIRTY, - TXN_LOCK_TIMEOUT, - TXN_TIMEOUT, -#endif - TXNNOSYNC, - TXNNOWAIT, - TXNPARENT, - TXNSYNC - }; - DBTCL_INFO *ip; - DB_TXN *parent; - DB_TXN *txn; - Tcl_Obj *res; - db_timeout_t lk_time, tx_time; - u_int32_t flag, lk_timeflag, tx_timeflag; - int i, optindex, result, ret; - char *arg, msg[MSG_SIZE], newname[MSG_SIZE]; - - result = TCL_OK; - memset(newname, 0, MSG_SIZE); - - parent = NULL; - flag = 0; - lk_timeflag = tx_timeflag = 0; - 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 TXNDIRTY: - flag |= DB_DIRTY_READ; - break; - case TXN_LOCK_TIMEOUT: - lk_timeflag = DB_SET_LOCK_TIMEOUT; - goto getit; - case TXN_TIMEOUT: - tx_timeflag = DB_SET_TXN_TIMEOUT; -getit: - if (i >= objc) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-txn_timestamp time?"); - return (TCL_ERROR); - } - result = Tcl_GetLongFromObj(interp, objv[i++], - (long *)(optindex == TXN_LOCK_TIMEOUT ? - &lk_time : &tx_time)); - if (result != TCL_OK) - return (TCL_ERROR); - break; -#endif - case TXNNOSYNC: - FLAG_CHECK2(flag, DB_DIRTY_READ); - flag |= DB_TXN_NOSYNC; - break; - case TXNNOWAIT: - FLAG_CHECK2(flag, DB_DIRTY_READ); - 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 TXNSYNC: - FLAG_CHECK2(flag, DB_DIRTY_READ); - flag |= DB_TXN_SYNC; - 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 = envp->txn_begin(envp, 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); - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)txn_Cmd, (ClientData)txn, NULL); - res = Tcl_NewStringObj(newname, strlen(newname)); - Tcl_SetObjResult(interp, res); - 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); - } - } - } - return (result); -} - -/* - * tcl_TxnStat -- - * - * PUBLIC: int tcl_TxnStat __P((Tcl_Interp *, int, - * PUBLIC: Tcl_Obj * CONST*, DB_ENV *)); - */ -int -tcl_TxnStat(interp, objc, objv, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->txn_stat(envp, &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. - */ - 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("Max Txns", sp->st_maxtxns); - MAKE_STAT_LIST("Number aborted txns", sp->st_naborts); - MAKE_STAT_LIST("Number active txns", sp->st_nactive); - MAKE_STAT_LIST("Maximum active txns", sp->st_maxnactive); - MAKE_STAT_LIST("Number txns begun", sp->st_nbegins); - MAKE_STAT_LIST("Number committed txns", sp->st_ncommits); - MAKE_STAT_LIST("Number restored txns", sp->st_nrestores); - MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait); - MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait); - for (i = 0, p = sp->st_txnarray; i < sp->st_nactive; i++, p++) - for (ip = LIST_FIRST(&__db_infohead); ip != NULL; - ip = LIST_NEXT(ip, 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; - } - } - Tcl_SetObjResult(interp, res); -error: - free(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, envp) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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 = envp->set_timeout(envp, (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 char *txncmds[] = { -#if CONFIG_TEST - "discard", - "id", - "prepare", -#endif - "abort", - "commit", - NULL - }; - enum txncmds { -#if CONFIG_TEST - TXNDISCARD, - TXNID, - TXNPREPARE, -#endif - TXNABORT, - TXNCOMMIT - }; - DBTCL_INFO *txnip; - DB_TXN *txnp; - Tcl_Obj *res; - int cmdindex, result, ret; - u_int8_t *gid; - - 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) { -#if 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(); - ret = txnp->id(txnp); - res = Tcl_NewIntObj(ret); - 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], NULL); - ret = txnp->prepare(txnp, gid); - /* - * !!! - * 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; -#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 char *commitopt[] = { - "-nosync", - "-sync", - NULL - }; - enum commitopt { - COMSYNC, - COMNOSYNC - }; - 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_CHECK(flag); - flag = DB_TXN_SYNC; - break; - case COMNOSYNC: - FLAG_CHECK(flag); - flag = DB_TXN_NOSYNC; - break; - } - } - - _debug_check(); - ret = txnp->commit(txnp, flag); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), - "txn commit"); - return (result); -} - -#if 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, envp, envip) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* 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); \ - Tcl_CreateObjCommand(interp, newname, \ - (Tcl_ObjCmdProc *)txn_Cmd, (ClientData)p->txn, NULL); \ - result = _SetListElem(interp, res, newname, strlen(newname), \ - p->gid, DB_XIDDATASIZE); \ - if (result != TCL_OK) \ - goto error; \ -} - - DBTCL_INFO *ip; - DB_PREPLIST prep[DBTCL_PREP], *p; - Tcl_Obj *res; - long count, i; - int result, ret; - char newname[MSG_SIZE]; - - result = TCL_OK; - /* - * No args for this. Error if there are some. - */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return (TCL_ERROR); - } - _debug_check(); - ret = envp->txn_recover(envp, 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 = envp->txn_recover( - envp, 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/bdb/tcl/tcl_util.c b/bdb/tcl/tcl_util.c deleted file mode 100644 index 3c0665f9e38..00000000000 --- a/bdb/tcl/tcl_util.c +++ /dev/null @@ -1,381 +0,0 @@ -/*- - * See the file LICENSE for redistribution information. - * - * Copyright (c) 1999-2001 - * Sleepycat Software. All rights reserved. - */ - -#include "db_config.h" - -#ifndef lint -static const char revid[] = "$Id: tcl_util.c,v 11.35 2002/08/06 06:21:42 bostic Exp $"; -#endif /* not lint */ - -#ifndef NO_SYSTEM_INCLUDES -#include <sys/types.h> - -#include <fcntl.h> -#include <stdlib.h> -#include <string.h> -#include <tcl.h> -#endif - -#include "db_int.h" -#include "dbinc/tcl_db.h" - -/* - * Prototypes for procedures defined later in this file: - */ -static int mutex_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); - -/* - * 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 char *rcmds[] = { - "rand", "random_int", "srand", - NULL - }; - enum rcmds { - RRAND, RRAND_INT, RSRAND - }; - long t; - int cmdindex, hi, lo, result, ret; - Tcl_Obj *res; - char msg[MSG_SIZE]; - - result = TCL_OK; - /* - * Get the command name index from the object based on the cmds - * defined above. This SHOULD NOT fail because we already checked - * in the 'berkdb' command. - */ - if (Tcl_GetIndexFromObj(interp, - objv[1], rcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) - return (IS_HELP(objv[1])); - - res = NULL; - switch ((enum rcmds)cmdindex) { - case RRAND: - /* - * Must be 0 args. Error if different. - */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return (TCL_ERROR); - } - ret = rand(); - res = Tcl_NewIntObj(ret); - break; - case RRAND_INT: - /* - * Must be 4 args. Error if different. - */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "lo hi"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &lo); - if (result != TCL_OK) - break; - result = Tcl_GetIntFromObj(interp, objv[3], &hi); - if (result == TCL_OK) { -#ifndef RAND_MAX -#define RAND_MAX 0x7fffffff -#endif - t = rand(); - if (t > RAND_MAX) { - snprintf(msg, MSG_SIZE, - "Max random is higher than %ld\n", - (long)RAND_MAX); - Tcl_SetResult(interp, msg, TCL_VOLATILE); - result = TCL_ERROR; - break; - } - _debug_check(); - ret = (int)(((double)t / ((double)(RAND_MAX) + 1)) * - (hi - lo + 1)); - ret += lo; - 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); - } - result = Tcl_GetIntFromObj(interp, objv[2], &lo); - if (result == TCL_OK) { - srand((u_int)lo); - res = Tcl_NewIntObj(0); - } - break; - } - /* - * Only set result if we have a res. Otherwise, lower - * functions have already done so. - */ - if (result == TCL_OK && res) - Tcl_SetObjResult(interp, res); - return (result); -} - -/* - * - * tcl_Mutex -- - * Opens an env mutex. - * - * PUBLIC: int tcl_Mutex __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *, - * PUBLIC: DBTCL_INFO *)); - */ -int -tcl_Mutex(interp, objc, objv, envp, envip) - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ - DB_ENV *envp; /* Environment pointer */ - DBTCL_INFO *envip; /* Info pointer */ -{ - DBTCL_INFO *ip; - Tcl_Obj *res; - _MUTEX_DATA *md; - int i, mode, nitems, result, ret; - char newname[MSG_SIZE]; - - md = NULL; - result = TCL_OK; - mode = nitems = ret = 0; - memset(newname, 0, MSG_SIZE); - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode nitems"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &mode); - if (result != TCL_OK) - return (TCL_ERROR); - result = Tcl_GetIntFromObj(interp, objv[3], &nitems); - if (result != TCL_OK) - return (TCL_ERROR); - - snprintf(newname, sizeof(newname), - "%s.mutex%d", envip->i_name, envip->i_envmutexid); - ip = _NewInfo(interp, NULL, newname, I_MUTEX); - if (ip == NULL) { - Tcl_SetResult(interp, "Could not set up info", - TCL_STATIC); - return (TCL_ERROR); - } - /* - * Set up mutex. - */ - /* - * Map in the region. - * - * XXX - * We don't bother doing this "right", i.e., using the shalloc - * functions, just grab some memory knowing that it's correctly - * aligned. - */ - _debug_check(); - if (__os_calloc(NULL, 1, sizeof(_MUTEX_DATA), &md) != 0) - goto posixout; - md->env = envp; - md->n_mutex = nitems; - md->size = sizeof(_MUTEX_ENTRY) * nitems; - - md->reginfo.type = REGION_TYPE_MUTEX; - md->reginfo.id = INVALID_REGION_TYPE; - md->reginfo.mode = mode; - md->reginfo.flags = REGION_CREATE_OK | REGION_JOIN_OK; - if ((ret = __db_r_attach(envp, &md->reginfo, md->size)) != 0) - goto posixout; - md->marray = md->reginfo.addr; - - /* Initialize a created region. */ - if (F_ISSET(&md->reginfo, REGION_CREATE)) - for (i = 0; i < nitems; i++) { - md->marray[i].val = 0; - if ((ret = __db_mutex_init_int(envp, - &md->marray[i].m, i, 0)) != 0) - goto posixout; - } - R_UNLOCK(envp, &md->reginfo); - - /* - * Success. Set up return. Set up new info - * and command widget for this mutex. - */ - envip->i_envmutexid++; - ip->i_parent = envip; - _SetInfoData(ip, md); - Tcl_CreateObjCommand(interp, newname, - (Tcl_ObjCmdProc *)mutex_Cmd, (ClientData)md, NULL); - res = Tcl_NewStringObj(newname, strlen(newname)); - Tcl_SetObjResult(interp, res); - - return (TCL_OK); - -posixout: - if (ret > 0) - Tcl_PosixError(interp); - result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mutex"); - _DeleteInfo(ip); - - if (md != NULL) { - if (md->reginfo.addr != NULL) - (void)__db_r_detach(md->env, - &md->reginfo, F_ISSET(&md->reginfo, REGION_CREATE)); - __os_free(md->env, md); - } - return (result); -} - -/* - * mutex_Cmd -- - * Implements the "mutex" widget. - */ -static int -mutex_Cmd(clientData, interp, objc, objv) - ClientData clientData; /* Mutex handle */ - Tcl_Interp *interp; /* Interpreter */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* The argument objects */ -{ - static char *mxcmds[] = { - "close", - "get", - "getval", - "release", - "setval", - NULL - }; - enum mxcmds { - MXCLOSE, - MXGET, - MXGETVAL, - MXRELE, - MXSETVAL - }; - DB_ENV *dbenv; - DBTCL_INFO *envip, *mpip; - _MUTEX_DATA *mp; - Tcl_Obj *res; - int cmdindex, id, result, newval; - - Tcl_ResetResult(interp); - mp = (_MUTEX_DATA *)clientData; - mpip = _PtrToInfo((void *)mp); - envip = mpip->i_parent; - dbenv = envip->i_envp; - 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], mxcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) - return (IS_HELP(objv[1])); - - res = NULL; - switch ((enum mxcmds)cmdindex) { - case MXCLOSE: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return (TCL_ERROR); - } - _debug_check(); - (void)__db_r_detach(mp->env, &mp->reginfo, 0); - res = Tcl_NewIntObj(0); - (void)Tcl_DeleteCommand(interp, mpip->i_name); - _DeleteInfo(mpip); - __os_free(mp->env, mp); - break; - case MXRELE: - /* - * Check for 1 arg. Error if different. - */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &id); - if (result != TCL_OK) - break; - MUTEX_UNLOCK(dbenv, &mp->marray[id].m); - res = Tcl_NewIntObj(0); - break; - case MXGET: - /* - * Check for 1 arg. Error if different. - */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &id); - if (result != TCL_OK) - break; - MUTEX_LOCK(dbenv, &mp->marray[id].m); - res = Tcl_NewIntObj(0); - break; - case MXGETVAL: - /* - * Check for 1 arg. Error if different. - */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &id); - if (result != TCL_OK) - break; - res = Tcl_NewLongObj((long)mp->marray[id].val); - break; - case MXSETVAL: - /* - * Check for 2 args. Error if different. - */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "id val"); - return (TCL_ERROR); - } - result = Tcl_GetIntFromObj(interp, objv[2], &id); - if (result != TCL_OK) - break; - result = Tcl_GetIntFromObj(interp, objv[3], &newval); - if (result != TCL_OK) - break; - mp->marray[id].val = newval; - 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); -} |