diff options
Diffstat (limited to 'db/tcl')
| -rw-r--r-- | db/tcl/docs/db.html | 266 | ||||
| -rw-r--r-- | db/tcl/docs/env.html | 303 | ||||
| -rw-r--r-- | db/tcl/docs/historic.html | 168 | ||||
| -rw-r--r-- | db/tcl/docs/index.html | 47 | ||||
| -rw-r--r-- | db/tcl/docs/library.html | 26 | ||||
| -rw-r--r-- | db/tcl/docs/lock.html | 187 | ||||
| -rw-r--r-- | db/tcl/docs/log.html | 142 | ||||
| -rw-r--r-- | db/tcl/docs/mpool.html | 189 | ||||
| -rw-r--r-- | db/tcl/docs/test.html | 149 | ||||
| -rw-r--r-- | db/tcl/docs/txn.html | 56 | ||||
| -rw-r--r-- | db/tcl/tcl_compat.c | 1055 | ||||
| -rw-r--r-- | db/tcl/tcl_db.c | 1771 | ||||
| -rw-r--r-- | db/tcl/tcl_db_pkg.c | 2246 | ||||
| -rw-r--r-- | db/tcl/tcl_dbcursor.c | 744 | ||||
| -rw-r--r-- | db/tcl/tcl_env.c | 678 | ||||
| -rw-r--r-- | db/tcl/tcl_internal.c | 440 | ||||
| -rw-r--r-- | db/tcl/tcl_lock.c | 655 | ||||
| -rw-r--r-- | db/tcl/tcl_log.c | 581 | ||||
| -rw-r--r-- | db/tcl/tcl_mp.c | 822 | ||||
| -rw-r--r-- | db/tcl/tcl_txn.c | 473 |
20 files changed, 10998 insertions, 0 deletions
diff --git a/db/tcl/docs/db.html b/db/tcl/docs/db.html new file mode 100644 index 000000000..c75ab6ecf --- /dev/null +++ b/db/tcl/docs/db.html @@ -0,0 +1,266 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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 conduit into the DB method functions. +They are all fairly straightforward and I describe them in terms of their +DB functions briefly here, with a link to the DB page where appropriate. +The first set of commands are those I believe will be the primary functions +used by most databases. Some are directly related to their DB counterparts, +and some are higher level functions that are useful to provide the user. +<P><B>> berkdb open [-env <I>env</I>]</B> +<BR><B> [-btree|-hash|-recno|-queue|-unknown]</B> +<BR><B> [-create] [-excl] [-nommap] [-rdonly] [-truncate] +[-mode +<I>mode</I>] [-errfile <I>filename</I>]</B> +<BR><B> [-dup] [-dupsort] [-recnum] [-renumber] [-revsplitoff] +[-snapshot]</B> +<BR><B> [-extent <I>size</I>]</B> +<BR><B> [-ffactor <I>density</I>]</B> +<BR><B> [-nelem <I>size</I>]</B> +<BR><B> [-lorder <I>order</I>]</B> +<BR><B> [-delim <I>delim</I>]</B> +<BR><B> [-len <I>len</I>]</B> +<BR><B> [-pad <I>pad</I>]</B> +<BR><B> [-source <I>file</I>]</B> +<BR><B> [-minkey <I>minkey</I>]</B> +<BR><B> [-cachesize {<I>gbytes bytes ncaches</I>}]</B> +<BR><B> [-pagesize <I>pagesize</I>]</B> +<BR><B> [--]</B> +<BR><B> [<I>filename </I>[<I>subdbname</I>]]</B> +<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). 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: +<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>-btree</B> - DB_BTREE database</LI> + +<LI> +<B>-hash</B> - DB_HASH database</LI> + +<LI> +<B>-recno </B> - DB_RECNO database</LI> + +<LI> +<B>-queue</B> - DB_QUEUE database</LI> + +<LI> +<B>-create</B> selects the DB_CREATE flag to create underlying files</LI> + +<LI> +<B>-excl</B> selects the DB_EXCL flag to exclusively create underlying +files</LI> + +<LI> +<B>-nommap</B> selects the DB_NOMMAP flag to forbid mmaping of files</LI> + +<LI> +<B>-rdonly</B> selects the DB_RDONLY flag for opening in read-only mode</LI> + +<LI> +<B>-truncate</B> selects the DB_TRUNCATE flag to truncate the database</LI> + +<LI> +<B>-mode<I> mode</I></B> specifies the mode for created files</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/db_set_errfile.html">DB->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>-dup </B>selects the DB_DUP flag to permit duplicates in the database</LI> + +<LI> +<B>-dupsort</B> selects the DB_DUPSORT flag to support sorted duplicates</LI> + +<LI> +<B>-recnum</B> selects the DB_RECNUM flag to support record numbers in +btrees</LI> + +<LI> +<B>-renumber </B>selects the DB_RENUMBER flag to support mutable record +numbers</LI> + +<LI> +<B>-revsplitoff </B>selects the DB_REVSPLITOFF flag to suppress reverse +splitting of pages on deletion</LI> + +<LI> +<B>-snapshot </B>selects the DB_SNAPSHOT flag to support database snapshots</LI> + +<LI> +<B>-extent </B>sets the size of a Queue database extent to the given <B><I>size +</I></B>using +the <A HREF="../../docs/api_c/db_set_q_extentsize.html">DB->set_q_extentsize</A> +method</LI> + +<LI> +<B>-ffactor</B> sets the hash table key density to the given <B><I>density +</I></B>using +the <A HREF="../../docs/api_c/db_set_h_ffactor.html">DB->set_h_ffactor</A> +method</LI> + +<LI> +<B>-nelem </B>sets the hash table size estimate to the given <B><I>size +</I></B>using +the <A HREF="../../docs/api_c/db_set_h_nelem.html">DB->set_h_nelem</A> +method</LI> + +<LI> +<B>-lorder </B>sets the byte order for integers stored in the database +meta-data to the given <B><I>order</I></B> using the <A HREF="../../docs/api_c/db_set_lorder.html">DB->set_lorder</A> +method</LI> + +<LI> +<B>-delim </B>sets the delimiting byte for variable length records to +<B><I>delim</I></B> +using the <A HREF="../../docs/api_c/db_set_re_delim.html">DB->set_re_delim</A> +method</LI> + +<LI> +<B>-len </B>sets the length of fixed-length records to <B><I>len</I></B> +using the <A HREF="../../docs/api_c/db_set_re_len.html">DB->set_re_len</A> +method</LI> + +<LI> +<B>-pad </B>sets the pad character used for fixed length records to +<B><I>pad</I></B> +using the <A HREF="../../docs/db_set_re_pad.html">DB->set_re_pad</A> method</LI> + +<LI> +<B>-source </B>sets the backing source file name to <B><I>file</I></B> +using the <A HREF="../../docs/api_c/db_set_re_source.html">DB->set_re_source</A> +method</LI> + +<LI> +<B>-minkey </B>sets the minimum number of keys per Btree page to <B><I>minkey</I></B> +using the <A HREF="../../docs/api_c/db_set_bt_minkey.html">DB->set_bt_minkey</A> +method</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/db_set_cachesize.html">DB->set_cachesize</A> +method</LI> + +<LI> +<B>-pagesize </B>sets the size of the database page to <B><I>pagesize </I></B>using +the <A HREF="../../docs/api_c/db_set_pagesize.html">DB->set_pagesize</A> +method</LI> + +<LI> +<B><I>filename</I></B> indicates the name of the database</LI> + +<LI> +<B><I>subdbname</I></B> indicate the name of the sub-database</LI> +</UL> + +<HR WIDTH="100%"> +<BR><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> 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> + +<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. +<BR> +<HR WIDTH="100%"><B>> <I>db</I> put</B> +<P>The <B>undocumented</B> options are: +<UL> +<LI> +<B>-nodupdata</B> 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.</LI> +</UL> + +<HR WIDTH="100%"><B>> <I>db</I> stat</B> +<P>The <B>undocumented</B> options are: +<UL> +<LI> +<B>-cachedcounts</B> This flag causes DB to return the cached key/record +counts, similar to the DB_CACHED_COUNTS flags to DB->stat.</LI> +</UL> + +<HR WIDTH="100%"><B>> <I>dbc</I> put</B> +<P>The <B>undocumented</B> options are: +<UL> +<LI> +<B>-nodupdata</B> 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.</LI> +</UL> + +</BODY> +</HTML> diff --git a/db/tcl/docs/env.html b/db/tcl/docs/env.html new file mode 100644 index 000000000..a1bd08fd1 --- /dev/null +++ b/db/tcl/docs/env.html @@ -0,0 +1,303 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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> +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> [-txn_max <I>max</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> +<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_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>-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>-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> +</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%"> +<BR><B>> berkdb envremove [-data_dir <I>directory</I>] [-force] [-home +<I>directory</I>] +-log_dir <I>directory</I>] [-tmp_dir <I>directory</I>] [-use_environ] [-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>-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/db/tcl/docs/historic.html b/db/tcl/docs/historic.html new file mode 100644 index 000000000..216dc456b --- /dev/null +++ b/db/tcl/docs/historic.html @@ -0,0 +1,168 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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/db/tcl/docs/index.html b/db/tcl/docs/index.html new file mode 100644 index 000000000..2866c1e23 --- /dev/null +++ b/db/tcl/docs/index.html @@ -0,0 +1,47 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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="./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/db/tcl/docs/library.html b/db/tcl/docs/library.html new file mode 100644 index 000000000..abd656d8e --- /dev/null +++ b/db/tcl/docs/library.html @@ -0,0 +1,26 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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/db/tcl/docs/lock.html b/db/tcl/docs/lock.html new file mode 100644 index 000000000..87a20e9a6 --- /dev/null +++ b/db/tcl/docs/lock.html @@ -0,0 +1,187 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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="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 [-lock_conflict] [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> +The second argument, <B>-lock_conflict</B>, selects the DB_LOCK_CONFLICT +flag to only run the detector if a lock conflict has occurred since the +last time the detector was run. +<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. +<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>obj</I> +<I>mode</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> diff --git a/db/tcl/docs/log.html b/db/tcl/docs/log.html new file mode 100644 index 000000000..35ecfc2f5 --- /dev/null +++ b/db/tcl/docs/log.html @@ -0,0 +1,142 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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] +[-curlsn] [-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>-curlsn</B> selects the DB_CURLSN flag to return the LSN of the next +record</LI> + +<LI> +<B>-flush </B>selects the DB_FLUSH flag to flush the log to disk.</LI> +</UL> + +<HR WIDTH="100%"> +<BR><A NAME="> <env> log_register"></A><B>> <env> log_register <I>db</I> +<I>file</I></B> +<P>This command registers a <B><I>file</I></B> and <B><I>db</I></B> with +the log manager. It is a direct call to the <A HREF="../../docs/api_c/log_register.html">log_register</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_unregister"></A><B>> <env> log_unregister <I>db</I></B> +<P>This command unregisters the file specified by the database handle <B><I>db +</I></B>from the log manager. It is a direct call to the <A HREF="../../docs/api_c/log_unregister.html">log_unregister</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> 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/db/tcl/docs/mpool.html b/db/tcl/docs/mpool.html new file mode 100644 index 000000000..666219306 --- /dev/null +++ b/db/tcl/docs/mpool.html @@ -0,0 +1,189 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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/db/tcl/docs/test.html b/db/tcl/docs/test.html new file mode 100644 index 000000000..10cf09efb --- /dev/null +++ b/db/tcl/docs/test.html @@ -0,0 +1,149 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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/db/tcl/docs/txn.html b/db/tcl/docs/txn.html new file mode 100644 index 000000000..863c9a875 --- /dev/null +++ b/db/tcl/docs/txn.html @@ -0,0 +1,56 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<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="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>> <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%"> +</BODY> +</HTML> diff --git a/db/tcl/tcl_compat.c b/db/tcl/tcl_compat.c new file mode 100644 index 000000000..41caee95c --- /dev/null +++ b/db/tcl/tcl_compat.c @@ -0,0 +1,1055 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_compat.c,v 11.22 2001/01/11 18:19:55 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 + +#define DB_DBM_HSEARCH 1 + +#include "db_int.h" +#include "tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +static int mutex_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); + +/* + * 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, "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); + action = 0; + if (Tcl_GetIndexFromObj(interp, objv[4], srchacts, + "action", TCL_EXACT, &actindex) != TCL_OK) + return (IS_HELP(objv[4])); + switch ((enum srchacts)actindex) { + case ACT_FIND: + action = FIND; + break; + case ACT_ENTER: + action = ENTER; + 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; + 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) { + result = _ReturnSetup(interp, Tcl_GetErrno(), "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; + int cmdindex, stindex, result, ret; + char *name, *t; + + 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], 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, "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, "dbminit"); + break; + case DBMFETCH: + /* + * 1 arg for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "key"); + return (TCL_ERROR); + } + key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize); + _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); + return (TCL_ERROR); + } + if (data.dptr == NULL || + (ret = __os_malloc(NULL, data.dsize + 1, NULL, &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(t, data.dsize + 1); + } + 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); + } + key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize); + data.dptr = + (char *)Tcl_GetByteArrayFromObj(objv[3], &data.dsize); + _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, "store"); + break; + case DBMDELETE: + /* + * 1 arg for this. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "key"); + return (TCL_ERROR); + } + key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize); + _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, "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, NULL, &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(t, key.dsize + 1); + } + 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); + } + key.dptr = (char *) + Tcl_GetByteArrayFromObj(objv[2], &key.dsize); + 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, NULL, &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(t, data.dsize + 1); + } + break; + } + 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, "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, "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); +} + +/* + * 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(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, "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, sizeof(*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, sizeof(*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, mp->env->lockfhp); + 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_NewIntObj(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); +} diff --git a/db/tcl/tcl_db.c b/db/tcl/tcl_db.c new file mode 100644 index 000000000..8e7215a27 --- /dev/null +++ b/db/tcl/tcl_db.c @@ -0,0 +1,1771 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_db.c,v 11.55 2000/11/28 20:12: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 "tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +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 *)); +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_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 *)); + +/* + * + * 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[] = { + "close", + "count", + "cursor", + "del", + "get", + "get_join", + "get_type", + "is_byteswapped", + "join", + "keyrange", + "put", + "stat", + "sync", +#if CONFIG_TEST + "test", +#endif + NULL + }; + enum dbcmds { + DBCLOSE, + DBCOUNT, + DBCURSOR, + DBDELETE, + DBGET, + DBGETJOIN, + DBGETTYPE, + DBSWAPPED, + DBJOIN, + DBKEYRANGE, + DBPUT, + DBSTAT, + DBSYNC +#if CONFIG_TEST + , DBTEST +#endif + }; + DB *dbp; + DBC *dbc; + DBTCL_INFO *dbip; + DBTCL_INFO *ip; + Tcl_Obj *res; + int cmdindex, 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) { + 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); + break; + case DBKEYRANGE: + result = tcl_DbKeyRange(interp, objc, objv, dbp); + 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); + res = Tcl_NewIntObj(ret); + 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); + if (ret == DB_BTREE) + res = Tcl_NewStringObj("btree", strlen("btree")); + else if (ret == DB_HASH) + res = Tcl_NewStringObj("hash", strlen("hash")); + else if (ret == DB_RECNO) + res = Tcl_NewStringObj("recno", strlen("recno")); + else if (ret == 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; +#if CONFIG_TEST + case DBTEST: + result = tcl_EnvTest(interp, objc, objv, dbp->dbenv); + break; +#endif + } + /* + * 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; + DBTYPE type; + u_int32_t flag; + int result, ret; + char *arg; + + result = TCL_OK; + flag = 0; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-recordcount?"); + return (TCL_ERROR); + } + + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], NULL); + if (strcmp(arg, "-recordcount") == 0) + flag = DB_RECORDCOUNT; + else if (strcmp(arg, "-cachedcounts") == 0) + flag = DB_CACHED_COUNTS; + else { + Tcl_SetResult(interp, + "db stat: unknown arg", TCL_STATIC); + return (TCL_ERROR); + } + } + + _debug_check(); + ret = dbp->stat(dbp, &sp, NULL, flag); + result = _ReturnSetup(interp, ret, "db stat"); + if (result == TCL_ERROR) + return (result); + + type = dbp->get_type(dbp); + /* + * 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("Estim. number of elements", hsp->hash_nelem); + MAKE_STAT_LIST("Fill factor", hsp->hash_ffactor); + MAKE_STAT_LIST("Buckets", hsp->hash_buckets); + 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("Number of records", qsp->qs_ndata); + MAKE_STAT_LIST("Number of pages", qsp->qs_pages); + MAKE_STAT_LIST("Bytes free", qsp->qs_pgfree); + 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); + } else { /* BTREE and RECNO are same stats */ + bsp = (DB_BTREE_STAT *)sp; + MAKE_STAT_LIST("Number of keys", bsp->bt_nkeys); + MAKE_STAT_LIST("Number of records", bsp->bt_ndata); + if (flag != DB_RECORDCOUNT) { + MAKE_STAT_LIST("Magic", bsp->bt_magic); + MAKE_STAT_LIST("Version", bsp->bt_version); + MAKE_STAT_LIST("Flags", bsp->bt_metaflags); + MAKE_STAT_LIST("Minimum keys per page", bsp->bt_minkey); + MAKE_STAT_LIST("Fixed record length", bsp->bt_re_len); + MAKE_STAT_LIST("Record pad", bsp->bt_re_pad); + MAKE_STAT_LIST("Page size", bsp->bt_pagesize); + MAKE_STAT_LIST("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); + } + } + Tcl_SetObjResult(interp, res); +error: + __os_free(sp, 0); + 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 */ +{ + DBTCL_INFO *p, *nextp; + u_int32_t flag; + int result, ret; + char *arg; + + result = TCL_OK; + flag = 0; + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nosync?"); + return (TCL_ERROR); + } + + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], NULL); + if (strcmp(arg, "-nosync") == 0) + flag = DB_NOSYNC; + else { + Tcl_SetResult(interp, + "dbclose: unknown arg", TCL_STATIC); + return (TCL_ERROR); + } + } + + /* + * 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); + _debug_check(); + ret = (dbp)->close(dbp, flag); + result = _ReturnSetup(interp, 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[] = { + "-append", + "-nodupdata", + "-nooverwrite", + "-partial", + "-txn", + NULL + }; + enum dbputopts { + DBPUT_APPEND, + DBGET_NODUPDATA, + 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; + db_recno_t recno; + u_int32_t flag; + int elemc, end, i, itmp, 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); + } + + 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". + */ + type = dbp->get_type(dbp); + + /* + * 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; + 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) { + case DBPUT_TXN: + if (i > (end - 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?"); + result = TCL_ERROR; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + txn = NAME_TO_TXN(arg); + if (txn == NULL) { + snprintf(msg, MSG_SIZE, + "Put: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case DBPUT_APPEND: + FLAG_CHECK(flag); + flag = DB_APPEND; + break; + case DBGET_NODUPDATA: + FLAG_CHECK(flag); + flag = DB_NODUPDATA; + 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 = Tcl_GetIntFromObj(interp, elemv[0], &itmp); + data.doff = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, elemv[1], &itmp); + data.dlen = itmp; + /* + * NOTE: We don't check result here because all we'd + * do is break anyway, and we are doing that. If you + * add code here, you WILL need to add the check + * for result. (See the check for save.doff, a few + * lines above and copy that.) + */ + break; + } + if (result != TCL_OK) + break; + } + + if (result == TCL_ERROR) + return (result); + + /* + * If 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 = Tcl_GetIntFromObj(interp, objv[objc-2], &itmp); + recno = itmp; + if (result != TCL_OK) + return (result); + } + } else { + key.data = Tcl_GetByteArrayFromObj(objv[objc-2], &itmp); + key.size = itmp; + } + /* + * XXX + * Tcl 8.1 Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug. + * + * This line (and the line for key.data above) were moved from + * the beginning of the function to here. + * + * 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 to make sure all Tcl_GetByteArrayFromObj calls + * are done last. + */ + data.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + data.size = itmp; + _debug_check(); + ret = dbp->put(dbp, txn, &key, &data, flag); + result = _ReturnSetup(interp, ret, "db put"); + if (ret == 0 && + (type == DB_RECNO || type == DB_QUEUE) && flag == DB_APPEND) { + res = Tcl_NewIntObj(recno); + Tcl_SetObjResult(interp, res); + } + return (result); +} + +/* + * tcl_db_get -- + */ +static int +tcl_DbGet(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 *dbgetopts[] = { + "-consume", + "-consume_wait", + "-get_both", + "-glob", + "-partial", + "-recno", + "-rmw", + "-txn", + NULL + }; + enum dbgetopts { + DBGET_CONSUME, + DBGET_CONSUME_WAIT, + DBGET_BOTH, + DBGET_GLOB, + DBGET_PART, + DBGET_RECNO, + DBGET_RMW, + DBGET_TXN + }; + DBC *dbc; + DBT key, data, save; + DBTYPE type; + DB_TXN *txn; + Tcl_Obj **elemv, *retlist; + db_recno_t recno; + u_int32_t flag, cflag, isdup, rmw; + int elemc, end, i, itmp, optindex, result, ret, useglob, userecno; + char *arg, *pattern, *prefix, msg[MSG_SIZE]; + + result = TCL_OK; + cflag = flag = rmw = 0; + useglob = userecno = 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)); + + /* + * Get the command name index from the object based on the options + * defined above. + */ + i = 2; + type = dbp->get_type(dbp); + end = objc; + while (i < end) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbgetopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + if (IS_HELP(objv[i]) == TCL_OK) + return (TCL_OK); + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbgetopts)optindex) { + 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 - 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, + "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 = Tcl_GetIntFromObj(interp, elemv[0], &itmp); + save.doff = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, elemv[1], &itmp); + save.dlen = itmp; + /* + * 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; + + if (type == DB_RECNO || type == DB_QUEUE) + userecno = 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 || + flag == DB_SET_RECNO || flag == DB_GET_BOTH || + flag == DB_CONSUME || flag == DB_CONSUME_WAIT)) { + if (flag == DB_GET_BOTH) { + if (userecno) { + result = Tcl_GetIntFromObj(interp, + objv[(objc - 2)], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = + Tcl_GetByteArrayFromObj(objv[objc-2], + &itmp); + key.size = itmp; + } + /* + * Already checked args above. Fill in key and save. + * Save is used in the dbp->get call below to fill in + * data. + */ + save.data = + Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + save.size = itmp; + } else if (flag != DB_CONSUME && flag != DB_CONSUME_WAIT) { + if (userecno) { + result = Tcl_GetIntFromObj( + interp, objv[(objc - 1)], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + key.size = itmp; + } + } + + memset(&data, 0, sizeof(data)); + data = save; + + _debug_check(); + + ret = dbp->get(dbp, txn, &key, &data, flag | rmw); + result = _ReturnSetup(interp, 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 (type == DB_RECNO || type == DB_QUEUE) + result = _SetListRecnoElem(interp, retlist, + *(db_recno_t *)key.data, data.data, + data.size); + else + result = _SetListElem(interp, retlist, + key.data, key.size, data.data, data.size); + /* + * Free space from DB_DBT_MALLOC + */ + __os_free(data.data, data.size); + } + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); + goto out; + } + + if (userecno) { + result = Tcl_GetIntFromObj(interp, objv[(objc - 1)], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + key.size = itmp; + } + ret = dbp->cursor(dbp, txn, &dbc, 0); + result = _ReturnSetup(interp, 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; + _debug_check(); + ret = dbc->c_get(dbc, &key, &data, cflag | rmw); + result = _ReturnSetup(interp, ret, "db get (cursor)"); + if (result == TCL_ERROR) + goto out1; + if (pattern) + cflag = DB_NEXT; + else + cflag = DB_NEXT_DUP; + + while (ret == 0 && result == TCL_OK) { + /* + * Build up our {name value} sublist + */ + result = _SetListElem(interp, retlist, + key.data, key.size, + data.data, data.size); + /* + * Free space from DB_DBT_MALLOC + */ + __os_free(data.data, data.size); + if (result != TCL_OK) + break; + /* + * Append {name value} to return list + */ + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + /* + * Restore any "partial" info we have saved. + */ + data = save; + 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 + */ + __os_free(data.data, data.size); + break; + } + } + dbc->c_close(dbc); +out1: + 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(prefix,0); + 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[] = { + "-glob", + "-txn", + NULL + }; + enum dbdelopts { + DBDEL_GLOB, + DBDEL_TXN + }; + DBC *dbc; + DBT key, data; + DBTYPE type; + DB_TXN *txn; + db_recno_t recno; + int i, itmp, optindex, result, ret; + u_int32_t flag; + char *arg, *pattern, *prefix, msg[MSG_SIZE]; + + result = TCL_OK; + 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 -txn, -glob or a list of keys. + */ + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], dbdelopts, "option", + TCL_EXACT, &optindex) != TCL_OK) { + /* + * If we don't have a -glob or -txn, then the + * remaining args must be exact keys. + * Reset the result so we don't get + * an errant error message if there is another error. + */ + if (IS_HELP(objv[i]) == TCL_OK) + return (TCL_OK); + Tcl_ResetResult(interp); + break; + } + i++; + switch ((enum dbdelopts)optindex) { + case DBDEL_TXN: + if (i == objc) { + /* + * Someone could conceivably have a key of + * the same name. So just break and use it. + */ + i--; + break; + } + arg = Tcl_GetStringFromObj(objv[i++], NULL); + txn = NAME_TO_TXN(arg); + if (txn == NULL) { + snprintf(msg, MSG_SIZE, + "Delete: Invalid txn: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + } + break; + case DBDEL_GLOB: + /* + * Get the pattern. Get the prefix and use cursors to + * get all the data items. + */ + if (i == objc) { + /* + * Someone could conceivably have a key of + * the same name. So just break and use it. + */ + i--; + break; + } + pattern = Tcl_GetStringFromObj(objv[i++], NULL); + break; + } + if (result != TCL_OK) + break; + } + + if (result != TCL_OK) + goto out; + + /* + * If we have a pattern AND more keys to process, then there + * is an error. Either we have some number of exact keys, + * or we have a pattern. + */ + if (pattern != NULL && i != objc) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? -glob pattern | key"); + result = TCL_ERROR; + 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 (pattern == NULL && i != (objc - 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "?args? -glob pattern | key"); + result = TCL_ERROR; + goto out; + } + + /* + * If we have remaining args, they are all exact keys. Call + * DB->del on each of those keys. + * + * If it is a RECNO database, the key is a record number and must be + * setup up to contain a db_recno_t. Otherwise the key is a "string". + */ + type = dbp->get_type(dbp); + ret = 0; + while (i < objc && ret == 0) { + memset(&key, 0, sizeof(key)); + if (type == DB_RECNO || type == DB_QUEUE) { + result = Tcl_GetIntFromObj(interp, objv[i++], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[i++], &itmp); + key.size = itmp; + } + _debug_check(); + ret = dbp->del(dbp, txn, &key, 0); + /* + * If we have any error, set up return result and stop + * processing keys. + */ + if (ret != 0) + break; + } + result = _ReturnSetup(interp, 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 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 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(prefix,0); + dbc->c_close(dbc); + result = _ReturnSetup(interp, 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[] = { + "-txn", "-update", + NULL + }; + enum dbcuropts { + DBCUR_TXN, DBCUR_UPDATE + }; + DB_TXN *txn; + u_int32_t flag; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 0; + txn = NULL; + /* + * If the user asks for -glob or -recno, it MUST be the second + * last arg given. If it isn't given, then we must check if + * they gave us a correct key. + */ + 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 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; + case DBCUR_UPDATE: + flag = DB_WRITECURSOR; + 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_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, NULL, &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 join"); + +out: + __os_free(listp, size); + 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[] = { + "-nosort", + "-txn", + NULL + }; + enum dbgetjopts { + DBGETJ_NOSORT, + DBGETJ_TXN + }; + DB_TXN *txn; + DB *elemdbp; + DBC **listp; + DBC *dbc; + DBT key, data; + Tcl_Obj **elemv, *retlist; + u_int32_t flag; + int adj, elemc, i, itmp, j, optindex, result, ret, size; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 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) { + case DBGETJ_NOSORT: + flag |= DB_JOIN_NOSORT; + adj++; + break; + 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, NULL, &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 cursor")) == + TCL_ERROR) + goto out; + memset(&key, 0, sizeof(key)); + memset(&data, 0, sizeof(data)); + key.data = Tcl_GetByteArrayFromObj(elemv[elemc-1], &itmp); + key.size = itmp; + ret = (listp[j])->c_get(listp[j], &key, &data, DB_SET); + if ((result = _ReturnSetup(interp, ret, "db cget")) == + TCL_ERROR) + goto out; + } + listp[j] = NULL; + _debug_check(); + ret = dbp->join(dbp, listp, &dbc, flag); + result = _ReturnSetup(interp, 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); + __os_free(key.data, key.size); + __os_free(data.data, data.size); + } + } + dbc->c_close(dbc); + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); +out: + while (j) { + if (listp[j]) + (listp[j])->c_close(listp[j]); + j--; + } + __os_free(listp, size); + 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; + db_recno_t count, recno; + int itmp, len, result, ret; + + result = TCL_OK; + count = 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 = Tcl_GetIntFromObj(interp, objv[2], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[2], &len); + key.size = len; + } + _debug_check(); + ret = dbp->cursor(dbp, NULL, &dbc, 0); + if (ret != 0) { + result = _ReturnSetup(interp, 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 cursor"); + goto out; + } + } + res = Tcl_NewIntObj(count); + Tcl_SetObjResult(interp, res); +out: + return (result); +} + +/* + * 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; + db_recno_t recno; + u_int32_t flag; + int i, itmp, myobjc, optindex, result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + flag = 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); + type = dbp->get_type(dbp); + 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 = Tcl_GetIntFromObj(interp, objv[i], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[i++], &itmp); + key.size = itmp; + } + _debug_check(); + ret = dbp->key_range(dbp, txn, &key, &range, flag); + result = _ReturnSetup(interp, ret, "db join"); + 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: + return (result); +} diff --git a/db/tcl/tcl_db_pkg.c b/db/tcl/tcl_db_pkg.c new file mode 100644 index 000000000..f83b5a7d2 --- /dev/null +++ b/db/tcl/tcl_db_pkg.c @@ -0,0 +1,2246 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_db_pkg.c,v 11.76 2001/01/19 18:02:36 bostic Exp $"; +#endif /* not lint */ + +#ifndef NO_SYSTEM_INCLUDES +#include <sys/types.h> + +#include <stdlib.h> +#include <string.h> +#include <tcl.h> +#endif + +#define DB_DBM_HSEARCH 1 + +#include "db_int.h" +#include "tcl_db.h" + +/* + * 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*)); + +/* + * 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[] = { + "dbremove", + "dbrename", + "dbverify", + "env", + "envremove", + "handles", + "open", + "upgrade", + "version", + /* All below are compatibility functions */ + "hcreate", "hsearch", "hdestroy", + "dbminit", "fetch", "store", + "delete", "firstkey", "nextkey", + "ndbm_open", "dbmclose", + /* All below are convenience functions */ + "rand", "random_int", "srand", + "debug_check", + NULL + }; + /* + * All commands enums below ending in X are compatibility + */ + enum berkdbcmds { + BDB_DBREMOVE, + BDB_DBRENAME, + BDB_DBVERIFY, + BDB_ENV, + BDB_ENVREMOVE, + BDB_HANDLES, + BDB_OPEN, + BDB_UPGRADE, + BDB_VERSION, + BDB_HCREATEX, BDB_HSEARCHX, BDB_HDESTROYX, + BDB_DBMINITX, BDB_FETCHX, BDB_STOREX, + BDB_DELETEX, BDB_FIRSTKEYX, BDB_NEXTKEYX, + BDB_NDBMOPENX, BDB_DBMCLOSEX, + BDB_RANDX, BDB_RAND_INTX, BDB_SRANDX, + BDB_DBGCKX + }; + static int env_id = 0; + static int db_id = 0; + static int ndbm_id = 0; + + DB *dbp; + DBM *ndbmp; + 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) { + case BDB_VERSION: + _debug_check(); + result = bdb_Version(interp, objc, objv); + break; + case BDB_HANDLES: + result = bdb_Handles(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_UPGRADE: + result = bdb_DbUpgrade(interp, objc, objv); + break; + case BDB_DBVERIFY: + result = bdb_DbVerify(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; + 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; + 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 DBENV->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[] = { + "-cachesize", + "-cdb", + "-cdb_alldb", + "-client_timeout", + "-create", + "-data_dir", + "-errfile", + "-errpfx", + "-home", + "-lock", + "-lock_conflict", + "-lock_detect", + "-lock_max", + "-lock_max_locks", + "-lock_max_lockers", + "-lock_max_objects", + "-log", + "-log_buffer", + "-log_dir", + "-log_max", + "-mmapsize", + "-mode", + "-nommap", + "-private", + "-recover", + "-recover_fatal", + "-region_init", + "-server", + "-server_timeout", + "-shm_key", + "-system_mem", + "-tmp_dir", + "-txn", + "-txn_max", + "-txn_timestamp", + "-use_environ", + "-use_environ_root", + "-verbose", + NULL + }; + /* + * !!! + * These have to be in the same order as the above, + * which is close to but not quite alphabetical. + */ + enum envopen { + ENV_CACHESIZE, + ENV_CDB, + ENV_CDB_ALLDB, + ENV_CLIENT_TO, + ENV_CREATE, + ENV_DATA_DIR, + ENV_ERRFILE, + ENV_ERRPFX, + ENV_HOME, + ENV_LOCK, + ENV_CONFLICT, + ENV_DETECT, + ENV_LOCK_MAX, + ENV_LOCK_MAX_LOCKS, + ENV_LOCK_MAX_LOCKERS, + ENV_LOCK_MAX_OBJECTS, + ENV_LOG, + ENV_LOG_BUFFER, + ENV_LOG_DIR, + ENV_LOG_MAX, + ENV_MMAPSIZE, + ENV_MODE, + ENV_NOMMAP, + ENV_PRIVATE, + ENV_RECOVER, + ENV_RECOVER_FATAL, + ENV_REGION_INIT, + ENV_SERVER, + ENV_SERVER_TO, + ENV_SHM_KEY, + ENV_SYSTEM_MEM, + ENV_TMP_DIR, + ENV_TXN, + ENV_TXN_MAX, + ENV_TXN_TIME, + ENV_USE_ENVIRON, + ENV_USE_ENVIRON_ROOT, + ENV_VERBOSE + }; + Tcl_Obj **myobjv, **myobjv1; + time_t time; + u_int32_t detect, gbytes, bytes, ncaches, open_flags, set_flag, size; + u_int8_t *conflicts; + int i, intarg, itmp, j, logbufset, logmaxset; + int mode, myobjc, nmodes, optindex, result, ret, temp; + long client_to, server_to, shm; + char *arg, *home, *server; + + result = TCL_OK; + mode = 0; + set_flag = 0; + home = NULL; + /* + * XXX + * If/when our Tcl interface becomes thread-safe, we should enable + * DB_THREAD here. Note that DB_THREAD currently does not work + * with log_get -next, -prev; if we wish to enable DB_THREAD, + * those must either be made thread-safe first or we must come up with + * a workaround. (We used to specify DB_THREAD if and only if + * logging was not configured.) + */ + open_flags = DB_JOINENV; + 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) { + 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; + default: + break; + } + } + if (server != NULL) { + ret = db_env_create(env, DB_CLIENT); + if (ret) + return (_ReturnSetup(interp, ret, "db_env_create")); + (*env)->set_errpfx((*env), ip->i_name); + (*env)->set_errcall((*env), _ErrorFunc); + if ((ret = (*env)->set_server((*env), 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_env_create")); + (*env)->set_errpfx((*env), ip->i_name); + (*env)->set_errcall((*env), _ErrorFunc); + } + + /* + * Get the command name index from the object based on the bdbcmds + * defined above. + */ + i = 2; + while (i < objc) { + 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) { + case ENV_SERVER: + case ENV_SERVER_TO: + case ENV_CLIENT_TO: + /* + * Already handled these, skip them and their arg. + */ + i++; + 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_flag, 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_LOG: + FLD_SET(open_flags, DB_INIT_LOG | DB_INIT_MPOOL); + FLD_CLR(open_flags, DB_JOINENV); + break; + 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_flag, 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_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_NOMMAP: + FLD_SET(set_flag, DB_NOMMAP); + 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_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_REGION_INIT: + _debug_check(); + ret = db_env_set_region_init(1); + result = _ReturnSetup(interp, ret, "region_init"); + break; + case ENV_CACHESIZE: + result = Tcl_ListObjGetElements(interp, objv[i], + &myobjc, &myobjv); + if (result == TCL_OK) + i++; + else + break; + j = 0; + if (myobjc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cachesize {gbytes bytes ncaches}?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, myobjv[0], &itmp); + gbytes = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[1], &itmp); + bytes = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[2], &itmp); + ncaches = itmp; + if (result != TCL_OK) + break; + _debug_check(); + ret = (*env)->set_cachesize(*env, gbytes, bytes, + ncaches); + result = _ReturnSetup(interp, ret, "set_cachesize"); + 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, "mmapsize"); + } + 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, "shm_key"); + } + break; + case ENV_LOG_MAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_max max?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK && logbufset) { + _debug_check(); + ret = (*env)->set_lg_max(*env, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, "log_max"); + logbufset = 0; + } else + logmaxset = intarg; + break; + case ENV_LOG_BUFFER: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-log_buffer size?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*env)->set_lg_bsize(*env, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, "log_bsize"); + logbufset = 1; + if (logmaxset) { + _debug_check(); + ret = (*env)->set_lg_max(*env, + (u_int32_t)logmaxset); + result = _ReturnSetup(interp, ret, + "log_max"); + logmaxset = 0; + logbufset = 0; + } + } + 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, NULL, &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(conflicts, size); + break; + } + } + _debug_check(); + ret = (*env)->set_lk_conflicts(*env, + (u_int8_t *)conflicts, nmodes); + __os_free(conflicts, size); + result = _ReturnSetup(interp, 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, "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, "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 = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + switch ((enum envopen)optindex) { + case ENV_LOCK_MAX: + ret = (*env)->set_lk_max(*env, + (u_int32_t)intarg); + break; + case ENV_LOCK_MAX_LOCKS: + ret = (*env)->set_lk_max_locks(*env, + (u_int32_t)intarg); + break; + case ENV_LOCK_MAX_LOCKERS: + ret = (*env)->set_lk_max_lockers(*env, + (u_int32_t)intarg); + break; + case ENV_LOCK_MAX_OBJECTS: + ret = (*env)->set_lk_max_objects(*env, + (u_int32_t)intarg); + break; + default: + break; + } + result = _ReturnSetup(interp, ret, "lock_max"); + } + break; + case ENV_TXN_MAX: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-txn_max max?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*env)->set_tx_max(*env, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, "txn_max"); + } + break; + case ENV_TXN_TIME: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-txn_timestamp time?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetLongFromObj(interp, objv[i++], + (long *)&time); + if (result == TCL_OK) { + _debug_check(); + ret = (*env)->set_tx_timestamp(*env, &time); + result = _ReturnSetup(interp, ret, + "txn_timestamp"); + } + 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_freestr(ip->i_errpfx); + if ((ret = + __os_strdup(*env, arg, &ip->i_errpfx)) != 0) { + result = _ReturnSetup(interp, 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, "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, "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, "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, "log_max"); + } + + if (result != TCL_OK) + goto error; + + if (set_flag) { + ret = (*env)->set_flags(*env, set_flag, 1); + result = _ReturnSetup(interp, 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, "env open"); + +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[] = { + "-btree", + "-cachesize", + "-create", + "-delim", + "-dup", + "-dupsort", + "-env", + "-errfile", + "-errpfx", + "-excl", + "-extent", + "-ffactor", + "-hash", + "-len", + "-lorder", + "-minkey", + "-mode", + "-nelem", + "-nommap", + "-pad", + "-pagesize", + "-queue", + "-rdonly", + "-recno", + "-recnum", + "-renumber", + "-revsplitoff", + "-snapshot", + "-source", + "-truncate", + "-test", + "-unknown", + "--", + NULL + }; + enum bdbopen { + TCL_DB_BTREE, + TCL_DB_CACHESIZE, + TCL_DB_CREATE, + TCL_DB_DELIM, + TCL_DB_DUP, + TCL_DB_DUPSORT, + 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_LORDER, + TCL_DB_MINKEY, + TCL_DB_MODE, + TCL_DB_NELEM, + TCL_DB_NOMMAP, + TCL_DB_PAD, + TCL_DB_PAGESIZE, + TCL_DB_QUEUE, + TCL_DB_RDONLY, + TCL_DB_RECNO, + TCL_DB_RECNUM, + TCL_DB_RENUMBER, + TCL_DB_REVSPLIT, + TCL_DB_SNAPSHOT, + TCL_DB_SOURCE, + TCL_DB_TRUNCATE, + TCL_DB_TEST, + TCL_DB_UNKNOWN, + TCL_DB_ENDARG + }; + + DBTCL_INFO *envip, *errip; + DBTYPE type; + DB_ENV *envp; + Tcl_Obj **myobjv; + u_int32_t gbytes, bytes, ncaches, open_flags; + int endarg, i, intarg, itmp, j, mode, myobjc; + int optindex, result, ret, set_err, set_flag, set_pfx, subdblen; + u_char *subdbtmp; + char *arg, *db, *subdb; + extern u_int32_t __ham_test __P((DB *, const void *, u_int32_t)); + + type = DB_UNKNOWN; + endarg = mode = set_err = set_flag = 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. See comment in bdb_EnvOpen(). + */ + open_flags = 0; + envp = 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_create")); + + /* + * 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) { + 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) { + case TCL_DB_ENV: + /* + * Already parsed this, skip it and the env pointer. + */ + i++; + continue; + 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_TEST: + (*dbp)->set_h_hash(*dbp, __ham_test); + 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_NOMMAP: + open_flags |= DB_NOMMAP; + break; + case TCL_DB_DUP: + set_flag |= DB_DUP; + break; + case TCL_DB_DUPSORT: + set_flag |= DB_DUPSORT; + break; + case TCL_DB_RECNUM: + set_flag |= DB_RECNUM; + break; + case TCL_DB_RENUMBER: + set_flag |= DB_RENUMBER; + break; + case TCL_DB_REVSPLIT: + set_flag |= DB_REVSPLITOFF; + break; + case TCL_DB_SNAPSHOT: + set_flag |= DB_SNAPSHOT; + break; + case TCL_DB_FFACTOR: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-ffactor density"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_h_ffactor(*dbp, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + "set_h_ffactor"); + } + break; + case TCL_DB_NELEM: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-nelem nelem"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_h_nelem(*dbp, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + "set_h_nelem"); + } + break; + case TCL_DB_LORDER: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-lorder 1234|4321"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_lorder(*dbp, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + "set_lorder"); + } + 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, + "set_re_delim"); + } + break; + case TCL_DB_LEN: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-len length"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_re_len(*dbp, + (u_int32_t)intarg); + result = _ReturnSetup(interp, 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, + "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, "set_re_source"); + break; + case TCL_DB_EXTENT: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-extent size"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_q_extentsize(*dbp, + (u_int32_t)intarg); + result = _ReturnSetup(interp, ret, + "set_q_extentsize"); + } + break; + case TCL_DB_MINKEY: + if (i >= objc) { + Tcl_WrongNumArgs(interp, 2, objv, + "-minkey minkey"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, objv[i++], &intarg); + if (result == TCL_OK) { + _debug_check(); + ret = (*dbp)->set_bt_minkey(*dbp, intarg); + result = _ReturnSetup(interp, ret, + "set_bt_minkey"); + } + break; + case TCL_DB_CACHESIZE: + result = Tcl_ListObjGetElements(interp, objv[i++], + &myobjc, &myobjv); + if (result != TCL_OK) + break; + j = 0; + if (myobjc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-cachesize {gbytes bytes ncaches}?"); + result = TCL_ERROR; + break; + } + result = Tcl_GetIntFromObj(interp, myobjv[0], &itmp); + gbytes = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[1], &itmp); + bytes = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, myobjv[2], &itmp); + ncaches = itmp; + if (result != TCL_OK) + break; + _debug_check(); + ret = (*dbp)->set_cachesize(*dbp, gbytes, bytes, + ncaches); + result = _ReturnSetup(interp, 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, + "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_freestr(errip->i_errpfx); + if ((ret = __os_strdup((*dbp)->dbenv, + arg, &errip->i_errpfx)) != 0) { + result = _ReturnSetup(interp, 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, NULL, &subdb)) != 0) { + Tcl_SetResult(interp, db_strerror(ret), + TCL_STATIC); + return (0); + } + memcpy(subdb, subdbtmp, subdblen); + subdb[subdblen] = '\0'; + } + } + if (set_flag) { + ret = (*dbp)->set_flags(*dbp, set_flag); + result = _ReturnSetup(interp, 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, db, subdb, type, open_flags, mode); + result = _ReturnSetup(interp, ret, "db open"); + +error: + if (subdb) + __os_free(subdb, subdblen + 1); + if (result == TCL_ERROR) { + /* + * 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_freestr(errip->i_errpfx); + errip->i_errpfx = NULL; + } + (void)(*dbp)->close(*dbp, 0); + *dbp = NULL; + } + return (result); +} + +/* + * bdb_DbRemove -- + * Implements the 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[] = { + "-env", "--", NULL + }; + enum bdbrem { + TCL_DBREM_ENV, + TCL_DBREM_ENDARG + }; + DB_ENV *envp; + DB *dbp; + int endarg, i, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, *subdb; + + envp = NULL; + dbp = NULL; + result = TCL_OK; + subdbtmp = NULL; + db = subdb = NULL; + endarg = 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], 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_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; + } + /* + * 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, + NULL, &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 = db_create(&dbp, envp, 0); + if (ret) { + result = _ReturnSetup(interp, ret, "db_create"); + goto error; + } + /* + * No matter what, we NULL out dbp after this call. + */ + ret = dbp->remove(dbp, db, subdb, 0); + result = _ReturnSetup(interp, ret, "db remove"); + dbp = NULL; +error: + if (subdb) + __os_free(subdb, subdblen + 1); + if (result == TCL_ERROR && dbp) + (void)dbp->close(dbp, 0); + return (result); +} + +/* + * bdb_DbRename -- + * Implements the DB->rename command. + */ +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[] = { + "-env", "--", NULL + }; + enum bdbmv { + TCL_DBMV_ENV, + TCL_DBMV_ENDARG + }; + DB_ENV *envp; + DB *dbp; + int endarg, i, newlen, optindex, result, ret, subdblen; + u_char *subdbtmp; + char *arg, *db, *newname, *subdb; + + envp = NULL; + dbp = NULL; + result = TCL_OK; + subdbtmp = NULL; + db = newname = subdb = NULL; + endarg = 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], 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_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; + } + /* + * 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, + NULL, &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, + NULL, &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 = db_create(&dbp, envp, 0); + if (ret) { + result = _ReturnSetup(interp, ret, "db_create"); + goto error; + } + /* + * No matter what, we NULL out dbp after this call. + */ + ret = dbp->rename(dbp, db, subdb, newname, 0); + result = _ReturnSetup(interp, ret, "db rename"); + dbp = NULL; +error: + if (subdb) + __os_free(subdb, subdblen + 1); + if (newname) + __os_free(newname, newlen + 1); + if (result == TCL_ERROR && dbp) + (void)dbp->close(dbp, 0); + return (result); +} + +/* + * 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[] = { + "-env", "-errfile", "-errpfx", "--", NULL + }; + enum bdbvrfy { + TCL_DBVRFY_ENV, + TCL_DBVRFY_ERRFILE, + TCL_DBVRFY_ERRPFX, + TCL_DBVRFY_ENDARG + }; + DB_ENV *envp; + DB *dbp; + FILE *errf; + int endarg, i, optindex, result, ret, flags; + char *arg, *db, *errpfx; + + envp = NULL; + dbp = NULL; + result = TCL_OK; + db = errpfx = NULL; + errf = NULL; + flags = endarg = 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_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_freestr(errpfx); + if ((ret = __os_strdup(NULL, arg, &errpfx)) != 0) { + result = _ReturnSetup(interp, 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_create"); + goto error; + } + + 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 verify"); +error: + if (errf != NULL) + fclose(errf); + if (errpfx != NULL) + __os_freestr(errpfx); + if (dbp) + (void)dbp->close(dbp, 0); + return (result); +} + +/* + * 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); +} + +/* + * 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); +} + +/* + * 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; + int endarg, i, optindex, result, ret, flags; + 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_create"); + goto error; + } + + ret = dbp->upgrade(dbp, db, flags); + result = _ReturnSetup(interp, ret, "db upgrade"); +error: + if (dbp) + (void)dbp->close(dbp, 0); + return (result); +} diff --git a/db/tcl/tcl_dbcursor.c b/db/tcl/tcl_dbcursor.c new file mode 100644 index 000000000..26e7b58c6 --- /dev/null +++ b/db/tcl/tcl_dbcursor.c @@ -0,0 +1,744 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_dbcursor.c,v 11.26 2001/01/11 18:19:55 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 "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 *)); +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[] = { + "close", + "del", + "dup", + "get", + "put", + NULL + }; + enum dbccmds { + 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) { + 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, "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, "dbc delete"); + break; + case DBCDUP: + result = tcl_DbcDup(interp, objc, objv, dbc); + break; + case DBCGET: + result = tcl_DbcGet(interp, objc, objv, dbc); + 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[] = { + "-after", "-before", "-current", + "-keyfirst", "-keylast", "-nodupdata", + "-partial", + NULL + }; + enum dbcutopts { + DBCPUT_AFTER, DBCPUT_BEFORE, DBCPUT_CURRENT, + DBCPUT_KEYFIRST,DBCPUT_KEYLAST, DBCPUT_NODUPDATA, + DBCPUT_PART + }; + DB *thisdbp; + DBT key, data; + DBTCL_INFO *dbcip, *dbip; + DBTYPE type; + Tcl_Obj **elemv, *res; + db_recno_t recno; + u_int32_t flag; + int elemc, i, itmp, optindex, result, ret; + + result = TCL_OK; + flag = 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) { + 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_NODUPDATA: + FLAG_CHECK(flag); + flag = DB_NODUPDATA; + 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 = Tcl_GetIntFromObj(interp, elemv[0], &itmp); + data.doff = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, elemv[1], &itmp); + data.dlen = itmp; + /* + * 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; + type = thisdbp->get_type(thisdbp); + } + /* + * 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 = Tcl_GetIntFromObj(interp, objv[objc-2], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + return (result); + } else { + key.data = Tcl_GetByteArrayFromObj(objv[objc-2], &itmp); + key.size = itmp; + } + } + data.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + data.size = itmp; + _debug_check(); + ret = dbc->c_put(dbc, &key, &data, flag); + result = _ReturnSetup(interp, ret, "dbc put"); + if (ret == 0 && (flag == DB_AFTER || flag == DB_BEFORE) + && type == DB_RECNO) { + res = Tcl_NewIntObj(*(db_recno_t *)key.data); + Tcl_SetObjResult(interp, res); + } +out: + return (result); +} + +/* + * tcl_dbc_get -- + */ +static int +tcl_DbcGet(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 *dbcgetopts[] = { + "-current", + "-first", + "-get_both", + "-get_recno", + "-join_item", + "-last", + "-next", + "-nextdup", + "-nextnodup", + "-partial", + "-prev", + "-prevnodup", + "-rmw", + "-set", + "-set_range", + "-set_recno", + NULL + }; + enum dbcgetopts { + 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; + DBTCL_INFO *dbcip, *dbip; + DBTYPE type; + Tcl_Obj **elemv, *myobj, *retlist; + db_recno_t recno; + u_int32_t flag; + int elemc, i, itmp, optindex, result, ret; + + result = TCL_OK; + flag = 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) { + case DBCGET_RMW: + flag |= DB_RMW; + break; + case DBCGET_CURRENT: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_CURRENT; + break; + case DBCGET_FIRST: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_FIRST; + break; + case DBCGET_LAST: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_LAST; + break; + case DBCGET_NEXT: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_NEXT; + break; + case DBCGET_PREV: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_PREV; + break; + case DBCGET_PREVNODUP: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_PREV_NODUP; + break; + case DBCGET_NEXTNODUP: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_NEXT_NODUP; + break; + case DBCGET_NEXTDUP: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_NEXT_DUP; + break; + case DBCGET_BOTH: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_GET_BOTH; + break; + case DBCGET_RECNO: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_GET_RECNO; + break; + case DBCGET_JOIN: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_JOIN_ITEM; + break; + case DBCGET_SET: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_SET; + break; + case DBCGET_SETRANGE: + FLAG_CHECK2(flag, DB_RMW); + flag |= DB_SET_RANGE; + break; + case DBCGET_SETRECNO: + FLAG_CHECK2(flag, DB_RMW); + 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 = Tcl_GetIntFromObj(interp, elemv[0], &itmp); + data.doff = itmp; + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, elemv[1], &itmp); + data.dlen = itmp; + /* + * 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; + 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; + type = thisdbp->get_type(thisdbp); + } + /* + * When we get here, we better have: + * 2 args, key and data if GET_BOTH was specified. + * 1 arg if -set, -set_range or -set_recno + * 0 in all other cases. + */ + if ((flag & DB_OPFLAGS_MASK) == DB_GET_BOTH) { + 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 = Tcl_GetIntFromObj( + interp, objv[objc-2], &itmp); + recno = itmp; + if (result == TCL_OK) { + key.data = &recno; + key.size = sizeof(db_recno_t); + } else + goto out; + } else { + key.data = Tcl_GetByteArrayFromObj( + objv[objc - 2], &itmp); + key.size = itmp; + } + data.data = + Tcl_GetByteArrayFromObj(objv[objc - 1], &itmp); + data.size = itmp; + } + } else if ((flag & DB_OPFLAGS_MASK) == DB_SET || + (flag & DB_OPFLAGS_MASK) == DB_SET_RANGE || + (flag & DB_OPFLAGS_MASK) == DB_SET_RECNO) { + if (i != (objc - 1)) { + Tcl_WrongNumArgs(interp, 2, objv, "?-args? key"); + result = TCL_ERROR; + goto out; + } + data.flags |= DB_DBT_MALLOC; + if ((flag & DB_OPFLAGS_MASK) == DB_SET_RECNO || + type == DB_RECNO || type == DB_QUEUE) { + result = Tcl_GetIntFromObj(interp, + objv[objc - 1], (int *)&recno); + key.data = &recno; + key.size = sizeof(db_recno_t); + } else { + key.data = + Tcl_GetByteArrayFromObj(objv[objc - 1], &itmp); + key.size = itmp; + } + } else { + if (i != objc) { + Tcl_WrongNumArgs(interp, 2, objv, "?-args?"); + result = TCL_ERROR; + goto out; + } + key.flags |= DB_DBT_MALLOC; + data.flags |= DB_DBT_MALLOC; + } + + _debug_check(); + ret = dbc->c_get(dbc, &key, &data, flag); + result = _ReturnSetup(interp, ret, "dbc get"); + if (result == TCL_ERROR) + goto out; + + retlist = Tcl_NewListObj(0, NULL); + if (ret == DB_NOTFOUND) + goto out1; + if ((flag & DB_OPFLAGS_MASK) == DB_GET_RECNO) { + recno = *((db_recno_t *)data.data); + myobj = Tcl_NewIntObj((int)recno); + result = Tcl_ListObjAppendElement(interp, retlist, myobj); + } else { + if ((type == DB_RECNO || type == DB_QUEUE) && key.data != NULL) + result = _SetListRecnoElem(interp, retlist, + *(db_recno_t *)key.data, data.data, data.size); + else + result = _SetListElem(interp, retlist, + key.data, key.size, data.data, data.size); + } + if (key.flags & DB_DBT_MALLOC) + __os_free(key.data, key.size); + if (data.flags & DB_DBT_MALLOC) + __os_free(data.data, data.size); +out1: + if (result == TCL_OK) + Tcl_SetObjResult(interp, retlist); +out: + return (result); + +} + +/* + * tcl_DbcDup -- + */ +static int +tcl_DbcDup(interp, objc, objv, dbc) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DBC *dbc; /* Cursor pointer */ +{ + static char *dbcdupopts[] = { + "-position", + NULL + }; + enum dbcdupopts { + DBCDUP_POS + }; + DB *thisdbp; + 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; + } + thisdbp = dbip->i_dbp; + } + /* + * 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 dup"); + _DeleteInfo(newdbcip); + } + } else { + Tcl_SetResult(interp, "Could not set up info", TCL_STATIC); + result = TCL_ERROR; + } +out: + return (result); + +} diff --git a/db/tcl/tcl_env.c b/db/tcl/tcl_env.c new file mode 100644 index 000000000..cb7b0d974 --- /dev/null +++ b/db/tcl/tcl_env.c @@ -0,0 +1,678 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_env.c,v 11.33 2001/01/11 18:19:55 bostic Exp $"; +#endif /* not lint */ + +#ifndef NO_SYSTEM_INCLUDES +#include <sys/types.h> + +#include <stdlib.h> +#include <tcl.h> +#endif + +#include "db_int.h" +#include "tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +static void _EnvInfoDelete __P((Tcl_Interp *, DBTCL_INFO *)); + +/* + * 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[] = { + "close", + "lock_detect", + "lock_id", + "lock_get", + "lock_stat", + "lock_vec", + "log_archive", + "log_compare", + "log_file", + "log_flush", + "log_get", + "log_put", + "log_register", + "log_stat", + "log_unregister", + "mpool", + "mpool_stat", + "mpool_sync", + "mpool_trickle", + "mutex", +#if CONFIG_TEST + "test", +#endif + "txn", + "txn_checkpoint", + "txn_stat", + "verbose", + NULL + }; + enum envcmds { + ENVCLOSE, + ENVLKDETECT, + ENVLKID, + ENVLKGET, + ENVLKSTAT, + ENVLKVEC, + ENVLOGARCH, + ENVLOGCMP, + ENVLOGFILE, + ENVLOGFLUSH, + ENVLOGGET, + ENVLOGPUT, + ENVLOGREG, + ENVLOGSTAT, + ENVLOGUNREG, + ENVMP, + ENVMPSTAT, + ENVMPSYNC, + ENVTRICKLE, + ENVMUTEX, +#if CONFIG_TEST + ENVTEST, +#endif + ENVTXN, + ENVTXNCKP, + ENVTXNSTAT, + ENVVERB + }; + DBTCL_INFO *envip; + DB_ENV *envp; + Tcl_Obj *res; + u_int32_t newval; + int cmdindex, result, ret; + + Tcl_ResetResult(interp); + envp = (DB_ENV *)clientData; + envip = _PtrToInfo((void *)envp); + result = TCL_OK; + + if (objc <= 1) { + Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs"); + return (TCL_ERROR); + } + if (envp == 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) { + 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. + */ + _EnvInfoDelete(interp, envip); + envip = NULL; + _debug_check(); + ret = envp->close(envp, 0); + result = _ReturnSetup(interp, ret, "env close"); + break; + case ENVLKDETECT: + result = tcl_LockDetect(interp, objc, objv, envp); + break; + case ENVLKSTAT: + result = tcl_LockStat(interp, objc, objv, envp); + 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 = lock_id(envp, &newval); + result = _ReturnSetup(interp, ret, "lock_id"); + if (result == TCL_OK) + res = Tcl_NewIntObj((int)newval); + break; + case ENVLKGET: + result = tcl_LockGet(interp, objc, objv, envp); + break; + case ENVLKVEC: + result = tcl_LockVec(interp, objc, objv, envp); + break; + case ENVLOGARCH: + result = tcl_LogArchive(interp, objc, objv, envp); + break; + case ENVLOGCMP: + result = tcl_LogCompare(interp, objc, objv); + break; + case ENVLOGFILE: + result = tcl_LogFile(interp, objc, objv, envp); + break; + case ENVLOGFLUSH: + result = tcl_LogFlush(interp, objc, objv, envp); + break; + case ENVLOGGET: + result = tcl_LogGet(interp, objc, objv, envp); + break; + case ENVLOGPUT: + result = tcl_LogPut(interp, objc, objv, envp); + break; + case ENVLOGREG: + result = tcl_LogRegister(interp, objc, objv, envp); + break; + case ENVLOGUNREG: + result = tcl_LogUnregister(interp, objc, objv, envp); + break; + case ENVLOGSTAT: + result = tcl_LogStat(interp, objc, objv, envp); + break; + case ENVMPSTAT: + result = tcl_MpStat(interp, objc, objv, envp); + break; + case ENVMPSYNC: + result = tcl_MpSync(interp, objc, objv, envp); + break; + case ENVTRICKLE: + result = tcl_MpTrickle(interp, objc, objv, envp); + break; + case ENVMP: + result = tcl_Mp(interp, objc, objv, envp, envip); + break; + case ENVTXNCKP: + result = tcl_TxnCheckpoint(interp, objc, objv, envp); + break; + case ENVTXNSTAT: + result = tcl_TxnStat(interp, objc, objv, envp); + break; + case ENVTXN: + result = tcl_Txn(interp, objc, objv, envp, envip); + break; + case ENVMUTEX: + result = tcl_Mutex(interp, objc, objv, envp, envip); + break; +#if CONFIG_TEST + case ENVTEST: + result = tcl_EnvTest(interp, objc, objv, envp); + break; +#endif + 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, envp, objv[2], objv[3]); + 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, envp, envip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *envp; /* Env pointer */ + DBTCL_INFO *envip; /* Info pointer */ +{ + static char *envremopts[] = { + "-data_dir", + "-force", + "-home", + "-log_dir", + "-server", + "-tmp_dir", + "-use_environ", + "-use_environ_root", + NULL + }; + enum envremopts { + ENVREM_DATADIR, + ENVREM_FORCE, + ENVREM_HOME, + ENVREM_LOGDIR, + ENVREM_SERVER, + ENVREM_TMPDIR, + ENVREM_USE_ENVIRON, + ENVREM_USE_ENVIRON_ROOT + }; + DB_ENV *e; + u_int32_t cflag, flag, forceflag; + int i, optindex, result, ret; + char *datadir, *home, *logdir, *server, *tmpdir; + + result = TCL_OK; + cflag = flag = forceflag = 0; + home = NULL; + datadir = logdir = tmpdir = NULL; + server = NULL; + + 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) { + 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; + 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; + 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 envp 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 (envp == NULL) { + if ((ret = db_env_create(&e, cflag)) != 0) { + result = _ReturnSetup(interp, ret, "db_env_create"); + goto error; + } + if (server != NULL) { + ret = e->set_server(e, server, 0, 0, 0); + result = _ReturnSetup(interp, ret, "set_server"); + if (result != TCL_OK) + goto error; + } + if (datadir != NULL) { + _debug_check(); + ret = e->set_data_dir(e, datadir); + result = _ReturnSetup(interp, 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, "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, "set_tmp_dir"); + 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 = envp; + } + + 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, "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. + * 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. + */ + 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); +} + +/* + * PUBLIC: int tcl_EnvVerbose __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *, + * PUBLIC: Tcl_Obj *)); + * + * tcl_EnvVerbose -- + */ +int +tcl_EnvVerbose(interp, envp, which, onoff) + Tcl_Interp *interp; /* Interpreter */ + DB_ENV *envp; /* Env pointer */ + Tcl_Obj *which; /* Which subsystem */ + Tcl_Obj *onoff; /* On or off */ +{ + static char *verbwhich[] = { + "chkpt", + "deadlock", + "recovery", + "wait", + NULL + }; + enum verbwhich { + ENVVERB_CHK, + ENVVERB_DEAD, + ENVVERB_REC, + 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_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 = envp->set_verbose(envp, wh, on); + return (_ReturnSetup(interp, ret, "env set verbose")); +} + +#if CONFIG_TEST +/* + * PUBLIC: int tcl_EnvTest __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *)); + * + * tcl_EnvTest -- + */ +int +tcl_EnvTest(interp, objc, objv, envp) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *envp; /* Env pointer */ +{ + static char *envtestcmd[] = { + "abort", + "copy", + NULL + }; + enum envtestcmd { + ENVTEST_ABORT, + ENVTEST_COPY + }; + static char *envtestat[] = { + "none", + "preopen", + "prerename", + "postlog", + "postlogmeta", + "postopen", + "postrename", + "postsync", + NULL + }; + enum envtestat { + ENVTEST_NONE, + ENVTEST_PREOPEN, + ENVTEST_PRERENAME, + ENVTEST_POSTLOG, + ENVTEST_POSTLOGMETA, + ENVTEST_POSTOPEN, + ENVTEST_POSTRENAME, + ENVTEST_POSTSYNC + }; + int *loc, optindex, result, testval; + + result = TCL_OK; + + 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 = &envp->test_abort; + break; + case ENVTEST_COPY: + loc = &envp->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_NONE: + testval = 0; + break; + case ENVTEST_PREOPEN: + testval = DB_TEST_PREOPEN; + break; + case ENVTEST_PRERENAME: + testval = DB_TEST_PRERENAME; + 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_POSTRENAME: + testval = DB_TEST_POSTRENAME; + break; + case ENVTEST_POSTSYNC: + testval = DB_TEST_POSTSYNC; + break; + default: + Tcl_SetResult(interp, "Illegal test location", TCL_STATIC); + return (TCL_ERROR); + } + + *loc = testval; + Tcl_SetResult(interp, "0", TCL_STATIC); + return (result); +} +#endif diff --git a/db/tcl/tcl_internal.c b/db/tcl/tcl_internal.c new file mode 100644 index 000000000..bdab60f4a --- /dev/null +++ b/db/tcl/tcl_internal.c @@ -0,0 +1,440 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_internal.c,v 11.27 2000/05/22 18:36:51 sue 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 "tcl_db.h" +#include "db_page.h" +#include "db_am.h" +#include "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: + */ + +#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), NULL, &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(p, sizeof(DBTCL_INFO)); + 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; + 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: char *_PtrToName __P((CONST void *)); + */ +char * +_PtrToName(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->i_name); + 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(p->i_lockobj.data, p->i_lockobj.size); + if (p->i_err != NULL) { + fclose(p->i_err); + p->i_err = NULL; + } + if (p->i_errpfx != NULL) + __os_freestr(p->i_errpfx); + __os_freestr(p->i_name); + __os_free(p, sizeof(DBTCL_INFO)); + + 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_NewIntObj(elem1); + myobjv[1] = Tcl_NewByteArrayObj(elem2, e2size); + thislist = Tcl_NewListObj(myobjc, myobjv); + if (thislist == NULL) + return (TCL_ERROR); + return (Tcl_ListObjAppendElement(interp, list, thislist)); + +} + +/* + * 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, char *)); + */ +int +_ReturnSetup(interp, ret, errmsg) + Tcl_Interp *interp; + int ret; + 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); + + switch (ret) { + case DB_NOTFOUND: + case DB_KEYEXIST: + case DB_KEYEMPTY: + return (TCL_OK); + default: + 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, NULL, &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(err, size); + 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; + int itmp, myobjc, result; + char msg[MSG_SIZE]; + + 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 = Tcl_GetIntFromObj(interp, myobjv[0], &itmp); + if (result == TCL_ERROR) + return (result); + lsn->file = itmp; + result = Tcl_GetIntFromObj(interp, myobjv[1], &itmp); + lsn->offset = itmp; + return (result); +} + +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%6d:", __debug_on); + fflush(stdout); + } + if (__debug_on++ == __debug_test || __debug_stop) + __db_loadme(); +} diff --git a/db/tcl/tcl_lock.c b/db/tcl/tcl_lock.c new file mode 100644 index 000000000..89f6eeb2b --- /dev/null +++ b/db/tcl/tcl_lock.c @@ -0,0 +1,655 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_lock.c,v 11.21 2001/01/11 18:19:55 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 "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 *)); + +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[] = { + "-lock_conflict", + "default", + "oldest", + "random", + "youngest", + NULL + }; + enum ldopts { + LD_CONFLICT, + LD_DEFAULT, + LD_OLDEST, + LD_RANDOM, + LD_YOUNGEST + }; + u_int32_t flag, policy; + int i, optindex, result, ret; + + result = TCL_OK; + flag = policy = 0; + i = 2; + while (i < objc) { + if (Tcl_GetIndexFromObj(interp, objv[i], + ldopts, "option", TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(objv[i])); + i++; + switch ((enum ldopts)optindex) { + case LD_DEFAULT: + FLAG_CHECK(policy); + policy = DB_LOCK_DEFAULT; + break; + case LD_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; + case LD_CONFLICT: + flag |= DB_LOCK_CONFLICT; + break; + } + } + + _debug_check(); + ret = lock_detect(envp, flag, policy, NULL); + result = _ReturnSetup(interp, 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; + db_lockmode_t mode; + u_int32_t flag, lockid; + int itmp, optindex, result; + char newname[MSG_SIZE]; + + result = TCL_OK; + 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 = + Tcl_GetIntFromObj(interp, objv[objc-2], &itmp)) != TCL_OK) + return (result); + lockid = itmp; + + /* + * XXX + * Tcl 8.1 Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug. + * + * The line below was originally before the Tcl_GetIntFromObj. + * + * 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 to make sure all Tcl_GetByteArrayFromObj calls + * are done last. + */ + obj.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + obj.size = itmp; + if ((result = _LockMode(interp, objv[(objc - 3)], &mode)) != TCL_OK) + return (result); + + /* + * 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); + } + 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 = lock_stat(envp, &sp, NULL); + result = _ReturnSetup(interp, 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("Max locks", sp->st_maxlocks); + MAKE_STAT_LIST("Max lockers", sp->st_maxlockers); + MAKE_STAT_LIST("Max 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("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); + Tcl_SetObjResult(interp, res); +error: + __os_free(sp, sizeof(*sp)); + 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 = lock_put(env, lock); + result = _ReturnSetup(interp, ret, "lock put"); + (void)Tcl_DeleteCommand(interp, lkip->i_name); + _DeleteInfo(lkip); + __os_free(lock, sizeof(DB_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", + NULL + }; + enum lkops { + LKGET, LKPUT, LKPUTALL, LKPUTOBJ + }; + DB_LOCK *lock; + DB_LOCKREQ list; + DBT obj; + Tcl_Obj **myobjv, *res, *thisop; + db_lockmode_t mode; + u_int32_t flag, lockid; + int i, itmp, myobjc, optindex, result, ret; + char *lockname, msg[MSG_SIZE], newname[MSG_SIZE]; + + result = TCL_OK; + memset(newname, 0, MSG_SIZE); + flag = 0; + mode = 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 = Tcl_GetIntFromObj(interp, objv[i++], &itmp); + if (result != TCL_OK) + return (result); + lockid = itmp; + + /* + * 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; + /* + * 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 to make sure all + * Tcl_GetByteArrayFromObj calls are done last. + */ + obj.data = Tcl_GetByteArrayFromObj(myobjv[1], &itmp); + obj.size = itmp; + ret = _GetThisLock(interp, envp, lockid, flag, + &obj, list.mode, newname); + if (ret != 0) { + result = _ReturnSetup(interp, 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); + 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; + obj.data = Tcl_GetByteArrayFromObj(myobjv[1], &itmp); + obj.size = itmp; + list.obj = &obj; + break; + } + /* + * We get here, we have set up our request, now call + * lock_vec. + */ + _debug_check(); + ret = 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, "lock put"); + /* + * 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(p->i_lock, sizeof(DB_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), NULL, &lock); + if (ret != 0) { + Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); + return (TCL_ERROR); + } + _debug_check(); + ret = lock_get(envp, lockid, flag, objp, mode, lock); + result = _ReturnSetup(interp, ret, "lock get"); + if (result == TCL_ERROR) { + __os_free(lock, sizeof(DB_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, NULL, &ip->i_lockobj.data); + if (ret != 0) { + Tcl_SetResult(interp, "Could not duplicate obj", + TCL_STATIC); + (void)lock_put(envp, lock); + __os_free(lock, sizeof(DB_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); +} diff --git a/db/tcl/tcl_log.c b/db/tcl/tcl_log.c new file mode 100644 index 000000000..20f8e8c02 --- /dev/null +++ b/db/tcl/tcl_log.c @@ -0,0 +1,581 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_log.c,v 11.21 2000/11/30 00:58:45 ubell 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 "tcl_db.h" + +/* + * 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 = log_archive(envp, &list, flag, NULL); + result = _ReturnSetup(interp, 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_free(list, 0); + 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(name, len/2); + ret = __os_malloc(envp, len, NULL, &name); + if (ret != 0) { + Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); + break; + } + _debug_check(); + ret = log_file(envp, &lsn, name, len); + len *= 2; + } + result = _ReturnSetup(interp, ret, "log_file"); + if (ret == 0) { + res = Tcl_NewStringObj(name, strlen(name)); + Tcl_SetObjResult(interp, res); + } + + if (name != NULL) + __os_free(name, len/2); + + 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 = log_flush(envp, lsnp); + result = _ReturnSetup(interp, 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 */ +{ + static char *loggetopts[] = { + "-checkpoint", "-current", "-first", + "-last", "-next", "-prev", + "-set", + NULL + }; + enum loggetopts { + LOGGET_CKP, LOGGET_CUR, LOGGET_FIRST, + LOGGET_LAST, LOGGET_NEXT, LOGGET_PREV, + LOGGET_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; + 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], + loggetopts, "option", TCL_EXACT, &optindex) != TCL_OK) + return (IS_HELP(objv[i])); + i++; + switch ((enum loggetopts)optindex) { + case LOGGET_CKP: + FLAG_CHECK(flag); + flag |= DB_CHECKPOINT; + break; + case LOGGET_CUR: + FLAG_CHECK(flag); + flag |= DB_CURRENT; + break; + case LOGGET_FIRST: + FLAG_CHECK(flag); + flag |= DB_FIRST; + break; + case LOGGET_LAST: + FLAG_CHECK(flag); + flag |= DB_LAST; + break; + case LOGGET_NEXT: + FLAG_CHECK(flag); + flag |= DB_NEXT; + break; + case LOGGET_PREV: + FLAG_CHECK(flag); + flag |= DB_PREV; + break; + case LOGGET_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)); + data.flags |= DB_DBT_MALLOC; + _debug_check(); + ret = log_get(envp, &lsn, &data, flag); + res = Tcl_NewListObj(0, NULL); + result = _ReturnSetup(interp, ret, "log_get"); + if (ret == 0) { + /* + * Success. Set up return list as {LSN data} where LSN + * is a sublist {file offset}. + */ + myobjc = 2; + myobjv[0] = Tcl_NewIntObj(lsn.file); + myobjv[1] = Tcl_NewIntObj(lsn.offset); + lsnlist = Tcl_NewListObj(myobjc, myobjv); + if (lsnlist == NULL) { + if (data.data != NULL) + __os_free(data.data, data.size); + return (TCL_ERROR); + } + result = Tcl_ListObjAppendElement(interp, res, lsnlist); + dataobj = Tcl_NewStringObj(data.data, data.size); + result = Tcl_ListObjAppendElement(interp, res, dataobj); + } + if (data.data != NULL) + __os_free(data.data, data.size); + + if (result == TCL_OK) + Tcl_SetObjResult(interp, res); + return (result); +} + +/* + * 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[] = { + "-checkpoint", "-curlsn", "-flush", + NULL + }; + enum logputopts { + LOGPUT_CKP, LOGPUT_CUR, LOGPUT_FLUSH + }; + DB_LSN lsn; + DBT data; + Tcl_Obj *intobj, *res; + u_int32_t flag; + int itmp, optindex, result, ret; + + result = TCL_OK; + flag = 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)); + data.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp); + data.size = itmp; + + /* + * 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_CKP: + flag = DB_CHECKPOINT; + break; + case LOGPUT_CUR: + flag = DB_CURLSN; + break; + case LOGPUT_FLUSH: + flag = DB_FLUSH; + break; + } + } + + if (result == TCL_ERROR) + return (result); + + _debug_check(); + ret = log_put(envp, &lsn, &data, flag); + result = _ReturnSetup(interp, ret, "log_put"); + if (result == TCL_ERROR) + return (result); + res = Tcl_NewListObj(0, NULL); + intobj = Tcl_NewIntObj(lsn.file); + result = Tcl_ListObjAppendElement(interp, res, intobj); + intobj = Tcl_NewIntObj(lsn.offset); + result = Tcl_ListObjAppendElement(interp, res, intobj); + Tcl_SetObjResult(interp, res); + return (result); +} + +/* + * tcl_LogRegister -- + * + * PUBLIC: int tcl_LogRegister __P((Tcl_Interp *, int, + * PUBLIC: Tcl_Obj * CONST*, DB_ENV *)); + */ +int +tcl_LogRegister(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 *dbp; + Tcl_Obj *res; + int result, ret; + char *arg, msg[MSG_SIZE]; + + result = TCL_OK; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "db filename"); + return (TCL_ERROR); + } + /* + * First comes the DB. + */ + arg = Tcl_GetStringFromObj(objv[2], NULL); + dbp = NAME_TO_DB(arg); + if (dbp == NULL) { + snprintf(msg, MSG_SIZE, + "LogRegister: Invalid db: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + + /* + * Next is the filename. + */ + arg = Tcl_GetStringFromObj(objv[3], NULL); + + _debug_check(); + ret = log_register(envp, dbp, arg); + result = _ReturnSetup(interp, ret, "log_register"); + if (result == TCL_OK) { + res = Tcl_NewIntObj((int)dbp->log_fileid); + Tcl_SetObjResult(interp, res); + } + 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 = log_stat(envp, &sp, NULL); + result = _ReturnSetup(interp, 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("Maximum log file size", sp->st_lg_max); + 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("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: + __os_free(sp, sizeof(*sp)); + return (result); +} + +/* + * tcl_LogUnregister -- + * + * PUBLIC: int tcl_LogUnregister __P((Tcl_Interp *, int, + * PUBLIC: Tcl_Obj * CONST*, DB_ENV *)); + */ +int +tcl_LogUnregister(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 *dbp; + char *arg, msg[MSG_SIZE]; + int result, ret; + + result = TCL_OK; + /* + * 1 arg for this. Error if more or less. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + arg = Tcl_GetStringFromObj(objv[2], NULL); + dbp = NAME_TO_DB(arg); + if (dbp == NULL) { + snprintf(msg, MSG_SIZE, + "log_unregister: Invalid db identifier: %s\n", arg); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return (TCL_ERROR); + } + _debug_check(); + ret = log_unregister(envp, dbp); + result = _ReturnSetup(interp, ret, "log_unregister"); + + return (result); +} diff --git a/db/tcl/tcl_mp.c b/db/tcl/tcl_mp.c new file mode 100644 index 000000000..b424deea2 --- /dev/null +++ b/db/tcl/tcl_mp.c @@ -0,0 +1,822 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_mp.c,v 11.24 2001/01/09 16:13:59 sue 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 "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); + } + } +} + +/* + * 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; + int result, ret; + + 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); + + _debug_check(); + ret = memp_sync(envp, &lsn); + result = _ReturnSetup(interp, 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 = memp_trickle(envp, percent, &pages); + result = _ReturnSetup(interp, 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); + } + /* + * XXX finfop is NULL here. Interface currently doesn't + * have all the stuff. Should expand interface. + */ + _debug_check(); + ret = memp_fopen(envp, file, flag, mode, (size_t)pgsize, NULL, &mpf); + if (ret != 0) { + result = _ReturnSetup(interp, ret, "mpool"); + _DeleteInfo(ip); + } else { + /* + * 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 = memp_stat(envp, &sp, &fsp, NULL); + result = _ReturnSetup(interp, 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("Region size", sp->st_regsize); + MAKE_STAT_LIST("Cache size (gbytes)", sp->st_gbytes); + MAKE_STAT_LIST("Cache size (bytes)", sp->st_bytes); + MAKE_STAT_LIST("Cache hits", sp->st_cache_hit); + MAKE_STAT_LIST("Cache misses", sp->st_cache_miss); + MAKE_STAT_LIST("Number of caches", sp->st_ncache); + MAKE_STAT_LIST("Pages mapped into address space", sp->st_map); + 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("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("Cached clean pages", sp->st_page_clean); + MAKE_STAT_LIST("Cached dirty pages", sp->st_page_dirty); + MAKE_STAT_LIST("Dirty pages trickled", sp->st_page_trickle); + MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait); + MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait); + /* + * 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; + savefsp = fsp; + for (; 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("Cache Hits", (*fsp)->st_cache_hit); + MAKE_STAT_LIST("Cache Misses", (*fsp)->st_cache_miss); + MAKE_STAT_LIST("Pages mapped into address space", + (*fsp)->st_map); + 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: + __os_free(sp, sizeof(*sp)); + if (savefsp != NULL) + __os_free(savefsp, 0); + 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 = memp_fclose(mp); + result = _ReturnSetup(interp, 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 = memp_fsync(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 = memp_fget(mp, &pgno, flag, &page); + result = _ReturnSetup(interp, 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_NewIntObj(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 = memp_fput(mp, page, flag); + else + ret = memp_fset(mp, page, flag); + + result = _ReturnSetup(interp, 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) ? 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) ? 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); +} diff --git a/db/tcl/tcl_txn.c b/db/tcl/tcl_txn.c new file mode 100644 index 000000000..dfe6b6cf6 --- /dev/null +++ b/db/tcl/tcl_txn.c @@ -0,0 +1,473 @@ +/*- + * See the file LICENSE for redistribution information. + * + * Copyright (c) 1999, 2000 + * Sleepycat Software. All rights reserved. + */ + +#include "db_config.h" + +#ifndef lint +static const char revid[] = "$Id: tcl_txn.c,v 11.24 2000/12/31 19:26:23 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 "tcl_db.h" + +/* + * Prototypes for procedures defined later in this file: + */ +static int tcl_TxnCommit __P((Tcl_Interp *, int, Tcl_Obj * CONST*, + DB_TXN *, DBTCL_INFO *)); + +/* + * _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 = txn_checkpoint(envp, (u_int32_t)kb, (u_int32_t)min, 0); + result = _ReturnSetup(interp, 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[] = { + "-nosync", + "-nowait", + "-parent", + "-sync", + NULL + }; + enum txnopts { + TXN_NOSYNC, + TXN_NOWAIT, + TXN_PARENT, + TXN_SYNC + }; + DBTCL_INFO *ip; + DB_TXN *parent; + DB_TXN *txn; + Tcl_Obj *res; + u_int32_t flag; + int i, optindex, result, ret; + char *arg, msg[MSG_SIZE], newname[MSG_SIZE]; + + result = TCL_OK; + memset(newname, 0, MSG_SIZE); + + parent = NULL; + flag = 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) { + case TXN_PARENT: + 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 TXN_NOWAIT: + FLAG_CHECK(flag); + flag |= DB_TXN_NOWAIT; + break; + case TXN_SYNC: + FLAG_CHECK(flag); + flag |= DB_TXN_SYNC; + break; + case TXN_NOSYNC: + FLAG_CHECK(flag); + flag |= DB_TXN_NOSYNC; + break; + } + } + snprintf(newname, sizeof(newname), "%s.txn%d", + envip->i_name, envip->i_envtxnid); + ip = _NewInfo(interp, NULL, newname, I_TXN); + if (ip == NULL) { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + return (TCL_ERROR); + } + _debug_check(); + ret = txn_begin(envp, parent, &txn, flag); + result = _ReturnSetup(interp, 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); + } + 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 */ +{ +#define MAKE_STAT_LSN(s, lsn) \ +do { \ + myobjc = 2; \ + myobjv[0] = Tcl_NewIntObj((lsn)->file); \ + myobjv[1] = Tcl_NewIntObj((lsn)->offset); \ + lsnlist = Tcl_NewListObj(myobjc, myobjv); \ + myobjc = 2; \ + myobjv[0] = Tcl_NewStringObj((s), strlen(s)); \ + myobjv[1] = lsnlist; \ + thislist = Tcl_NewListObj(myobjc, myobjv); \ + result = Tcl_ListObjAppendElement(interp, res, thislist); \ + if (result != TCL_OK) \ + goto error; \ +} while (0); + + 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 = txn_stat(envp, &sp, NULL); + result = _ReturnSetup(interp, 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_LSN("LSN of pending checkpoint", &sp->st_pending_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("Number txns begun", sp->st_nbegins); + MAKE_STAT_LIST("Number committed txns", sp->st_ncommits); + 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 && + (txn_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: + __os_free(sp, sizeof(*sp)); + return (result); +} + +/* + * txn_Cmd -- + * Implements the "txn" widget. + * + * PUBLIC: int txn_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); + */ +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[] = { + "abort", + "commit", + "id", + "prepare", + NULL + }; + enum txncmds { + TXNABORT, + TXNCOMMIT, + TXNID, + TXNPREPARE + }; + DBTCL_INFO *txnip; + DB_TXN *txnp; + Tcl_Obj *res; + int cmdindex, result, ret; + + 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) { + case TXNID: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = txn_id(txnp); + res = Tcl_NewIntObj(ret); + break; + case TXNPREPARE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = txn_prepare(txnp); + result = _ReturnSetup(interp, ret, "txn prepare"); + break; + case TXNCOMMIT: + result = tcl_TxnCommit(interp, objc, objv, txnp, txnip); + _TxnInfoDelete(interp, txnip); + (void)Tcl_DeleteCommand(interp, txnip->i_name); + _DeleteInfo(txnip); + break; + case TXNABORT: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + ret = txn_abort(txnp); + result = _ReturnSetup(interp, ret, "txn abort"); + _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 = txn_commit(txnp, flag); + result = _ReturnSetup(interp, ret, "txn commit"); + return (result); +} |