2 Jul 2004 05:00
clisp-cvs digest, Vol 1 #598 - 3 msgs
<clisp-cvs-request <at> lists.sourceforge.net>
2004-07-02 03:00:20 GMT
2004-07-02 03:00:20 GMT
Send clisp-cvs mailing list submissions to clisp-cvs <at> lists.sourceforge.net To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to clisp-cvs-request <at> lists.sourceforge.net You can reach the person managing the list at clisp-cvs-admin <at> lists.sourceforge.net When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src genclisph.d,1.131,1.132 ChangeLog,1.3267,1.3268 (Sam Steingold) 2. clisp/doc unix-ent.xml,1.40,1.41 (Sam Steingold) 3. clisp/modules/berkeley-db test.tst,1.1,1.2 dbi.lisp,1.10,1.11 berkeley-db.xml,1.16,1.17 bdb.c,1.32,1.33 (Sam Steingold) --__--__-- Message: 1 From: Sam Steingold <sds <at> users.sourceforge.net> To: clisp-cvs <at> lists.sourceforge.net Subject: clisp/src genclisph.d,1.131,1.132 ChangeLog,1.3267,1.3268 Date: Thu, 01 Jul 2004 15:15:37 +0000 Reply-To: clisp-devel <at> lists.sourceforge.net Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12101/src Modified Files: genclisph.d ChangeLog Log Message: keys and values can also be STRING and (INTEGER 0) Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.131 retrieving revision 1.132 diff -u -d -r1.131 -r1.132 --- genclisph.d 24 Jun 2004 16:58:07 -0000 1.131 +++ genclisph.d 1 Jul 2004 15:15:32 -0000 1.132 <at> <at> -374,11 +374,11 <at> <at> printf("#define minus_bit(n) (-1%s<<(n))\n",Lsuffix); #if notused printf("#define minus_bitm(n) (-2%s<<((n)-1))\n",Lsuffix); +#endif printf("#define floor(a_from_floor,b_from_floor) ((a_from_floor) / (b_from_floor))\n"); printf("#define ceiling(a_from_ceiling,b_from_ceiling) (((a_from_ceiling) + (b_from_ceiling) - 1) / (b_from_ceiling))\n"); printf("#define round_down(a_from_round,b_from_round) (floor(a_from_round,b_from_round)*(b_from_round))\n"); printf("#define round_up(a_from_round,b_from_round) (ceiling(a_from_round,b_from_round)*(b_from_round))\n"); -#endif #if defined(GNU) #ifdef DECALPHA printf("#define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize) arrayeltype arrayvar[(arraysize)+1]\n"); <at> <at> -597,8 +597,8 <at> <at> printf("#define objectplus(obj,offset) as_object(as_oint(obj)+(soint)(offset))\n"); #endif #if !(defined(WIDE_SOFT) || defined(WIDE_AUXI)) -#if notused printf("#define wbit bit\n"); +#if notused printf("#define wbitm bitm\n"); #endif printf("#define wbit_test bit_test\n"); <at> <at> -1853,6 +1853,7 <at> <at> printf("#define TheAsciz(obj) ((char*)(&TheSbvector(obj)->data[0]))\n"); printf("extern object vectorof (uintC len);\n"); + printf("extern object allocate_bignum (uintC len, sintB sign);\n"); #if notused printf("extern object allocate_bit_vector_0 (uintL len);\n"); printf("extern chart up_case (chart ch);\n"); Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3267 retrieving revision 1.3268 diff -u -d -r1.3267 -r1.3268 --- ChangeLog 30 Jun 2004 14:50:43 -0000 1.3267 +++ ChangeLog 1 Jul 2004 15:15:32 -0000 1.3268 <at> <at> -1,3 +1,32 <at> <at> +2004-07-01 Sam Steingold <sds <at> gnu.org> + + keys and values can also be STRING and (INTEGER 0) + * modules/berkeley-db/bdb.c (SYSCALL1): new macro (with clean-up) + (BDB:ENV-CLOSE, BDB:DB-CLOSE, BDB:DB-DEL, BDB:DB-PUT) + (BDB:DB-KEY-RANGE, BDB:CURSOR-CLOSE, BDB:CURSOR-PUT): use it + (BDB:ENV-SET-OPTIONS): DATA_DIR can be a list + (BDB:ENV-GET-OPTIONS, BDB:DB-GET-OPTIONS): return all as a plist, + not as multiple values + (dbt_o_t): new typedef + (check_dbt_type, check_dbt_object, free_dbt): new functions + (fill_dbt): also return the type of the object + (dbt_to_object): accept the object type as the second argument + (BDB:DB-GET): accept :TYPE keyword argument + (BDB:DB-OPEN): do not call physical_namestring() on strings + because then it is resolved by Berkeley-DB relative to data_dirs + (BDB:DB-SET-OPTIONS, BDB:DB-GET-OPTIONS): accept :RE_LEN + (DEFINE_DB_GETTER): new macro + (db_get_lorder, db_get_pagesize): use it + (db_get_re_len): new function + (BDB:CURSOR-GET): return KEY and VAL with specified type + (BDB:TXN-BEGIN): finalize TXN with BDB::TXN-DISCARD + (BDB:TXN-COMMIT, BDB:TXN-DISCARD, BDB:TXN-ABORT): invalidate TXN + * modules/berkeley-db/dbi.lisp (with-cursor): new macro + (with-open-db): must use BDB:DB-CREATE and then BDB:DB-OPEN + (close): added a TXN method + * genclisph.d (ceiling, wbit): enabled + (allocate_bignum): added + 2004-06-30 Sam Steingold <sds <at> gnu.org> * spvw.d (main): reset `argv_for' to `for_exec' after processing --__--__-- Message: 2 From: Sam Steingold <sds <at> users.sourceforge.net> To: clisp-cvs <at> lists.sourceforge.net Subject: clisp/doc unix-ent.xml,1.40,1.41 Date: Thu, 01 Jul 2004 15:15:38 +0000 Reply-To: clisp-devel <at> lists.sourceforge.net Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12101/doc Modified Files: unix-ent.xml Log Message: keys and values can also be STRING and (INTEGER 0) Index: unix-ent.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/unix-ent.xml,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- unix-ent.xml 24 Jun 2004 23:20:47 -0000 1.40 +++ unix-ent.xml 1 Jul 2004 15:15:36 -0000 1.41 <at> <at> -126,6 +126,12 <at> <at> <!ENTITY DB_set_encrypt "<ulink url='&bdb;db_set_encrypt.html'><function>DB->set_encrypt</function></ulink>"> <!ENTITY DB_get_errfile "<ulink url='&bdb;db_set_errfile.html'><function>DB->get_errfile</function></ulink>"> <!ENTITY DB_set_errfile "<ulink url='&bdb;db_set_errfile.html'><function>DB->set_errfile</function></ulink>"> +<!ENTITY DB_get_lorder "<ulink url='&bdb;db_set_lorder.html'><function>DB->get_lorder</function></ulink>"> +<!ENTITY DB_set_lorder "<ulink url='&bdb;db_set_lorder.html'><function>DB->set_lorder</function></ulink>"> +<!ENTITY DB_get_pagesize "<ulink url='&bdb;db_set_pagesize.html'><function>DB->get_pagesize</function></ulink>"> +<!ENTITY DB_set_pagesize "<ulink url='&bdb;db_set_pagesize.html'><function>DB->set_pagesize</function></ulink>"> +<!ENTITY DB_get_re_len "<ulink url='&bdb;db_set_re_len.html'><function>DB->get_re_len</function></ulink>"> +<!ENTITY DB_set_re_len "<ulink url='&bdb;db_set_re_len.html'><function>DB->set_re_len</function></ulink>"> <!ENTITY DB_get_type "<ulink url='&bdb;db_get_type.html'><function>DB->get_type</function></ulink>"> <!ENTITY DB_join "<ulink url='&bdb;db_join.html'><function>DB->join</function></ulink>"> <!ENTITY DB_key_range "<ulink url='&bdb;db_key_range.html'><function>DB->key_range</function></ulink>"> --__--__-- Message: 3 From: Sam Steingold <sds <at> users.sourceforge.net> To: clisp-cvs <at> lists.sourceforge.net Subject: clisp/modules/berkeley-db test.tst,1.1,1.2 dbi.lisp,1.10,1.11 berkeley-db.xml,1.16,1.17 bdb.c,1.32,1.33 Date: Thu, 01 Jul 2004 15:15:38 +0000 Reply-To: clisp-devel <at> lists.sourceforge.net Update of /cvsroot/clisp/clisp/modules/berkeley-db In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12101/modules/berkeley-db Modified Files: test.tst dbi.lisp berkeley-db.xml bdb.c Log Message: keys and values can also be STRING and (INTEGER 0) Index: bdb.c =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/bdb.c,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- bdb.c 29 Jun 2004 15:29:56 -0000 1.32 +++ bdb.c 1 Jul 2004 15:15:35 -0000 1.33 <at> <at> -96,13 +96,14 <at> <at> } else funcall(L(error_of_type),7); NOTREACHED; } -#define SYSCALL(caller,args) do { \ +#define SYSCALL1(caller,args,cleanup) do { \ int db_error_code; \ begin_system_call(); \ - db_error_code = caller args; \ + db_error_code = caller args; cleanup \ if (db_error_code) error_bdb(db_error_code,#caller); \ end_system_call(); \ } while(0) +#define SYSCALL(caller,args) SYSCALL1(caller,args,) /* check whether the OBJ has type TYPE and return its handle can trigger GC */ <at> <at> -218,8 +219,11 <at> <at> { /* close DB environment */ DB_ENV **dbe = (DB_ENV**)object_handle(popSTACK(),`BDB::ENV`,OH_ADDRESS); if (*dbe) { - SYSCALL((*dbe)->close,(*dbe,0)); - *dbe = NULL; + /* FIXME: if you do this before closing all dependents, + this will lead to a crash (error now, segfault later), + so FINALIZEing DBE with ENV-CLOSE is dangerous !! + Looks like we will need to cross-link parents and children!! */ + SYSCALL1((*dbe)->close,(*dbe,0),{*dbe=NULL;}); VALUES1(T); } else VALUES1(NIL); } <at> <at> -400,8 +404,16 <at> <at> { SYSCALL(dbe->set_tmp_dir,(dbe,tmpz)); }); } else skipSTACK(1); if (!missingp(STACK_0)) { /* DATA_DIR */ - with_string_0(physical_namestring(popSTACK()),GLO(pathname_encoding),dataz, - { SYSCALL(dbe->set_data_dir,(dbe,dataz)); }); + if (consp(STACK_0)) { + do { + with_string_0(physical_namestring(Car(STACK_0)),GLO(pathname_encoding), + dataz, { SYSCALL(dbe->set_data_dir,(dbe,dataz)); }); + STACK_0 = Cdr(STACK_0); + } while (consp(STACK_0)); + skipSTACK(1); + } else + with_string_0(physical_namestring(popSTACK()),GLO(pathname_encoding), + dataz, { SYSCALL(dbe->set_data_dir,(dbe,dataz)); }); } else skipSTACK(1); if (!missingp(STACK_0)) { /* TX_MAX */ u_int32_t tx_max = posfixnum_to_L(check_posfixnum(STACK_0)); <at> <at> -594,19 +606,25 <at> <at> what = STACK_0; skipSTACK(2); restart_ENV_GET_OPTIONS: if (missingp(what)) { /* get everything */ - value1 = env_get_verbose(dbe); pushSTACK(value1); - value1 = env_get_flags_list(dbe); pushSTACK(value1); - pushSTACK(env_get_tx_timestamp(dbe)); - pushSTACK(env_get_tx_max(dbe)); - pushSTACK(env_get_tmp_dir(dbe)); - value1 = env_get_data_dirs(dbe); pushSTACK(value1); - pushSTACK(env_get_tas_spins(dbe)); - pushSTACK(env_get_shm_key(dbe)); - pushSTACK(env_get_errfile(dbe)); - value1 = env_get_timeouts(dbe); pushSTACK(value1); - pushSTACK(env_get_home_dir(dbe,false)); - value1 = env_get_open_flags(dbe,false); pushSTACK(value1); - funcall(L(values),12); + uintL count = 0; + pushSTACK(`:VERBOSE`); value1 = env_get_verbose(dbe); + pushSTACK(value1); count++; + pushSTACK(`:FLAGS`); value1 = env_get_flags_list(dbe); + pushSTACK(value1); count++; + pushSTACK(`:TIMESTAMP`); pushSTACK(env_get_tx_timestamp(dbe)); count++; + pushSTACK(`:TX_MAX`); pushSTACK(env_get_tx_max(dbe)); count++; + pushSTACK(`:TMP_DIR`); pushSTACK(env_get_tmp_dir(dbe)); count++; + pushSTACK(`:DATA_DIR`); value1 = env_get_data_dirs(dbe); + pushSTACK(value1); count++; + pushSTACK(`:TAS_SPINS`); pushSTACK(env_get_tas_spins(dbe)); count++; + pushSTACK(`:SHM_KEY`); pushSTACK(env_get_shm_key(dbe)); count++; + pushSTACK(`:ERRFILE`); pushSTACK(env_get_errfile(dbe)); count++; + pushSTACK(`:TIMEOUT`); value1 = env_get_timeouts(dbe); + pushSTACK(value1); count++; + pushSTACK(`:HOMEDIR`); pushSTACK(env_get_home_dir(dbe,false)); count++; + pushSTACK(`:OPEN`); value1 = env_get_open_flags(dbe,false); + pushSTACK(value1); count++; + VALUES1(listof(count*2)); } else if (eq(what,S(Kverbose))) { VALUES1(env_get_verbose(dbe)); } else if (eq(what,`:FLAGS`)) { <at> <at> -726,8 +744,7 <at> <at> u_int32_t flags = missingp(STACK_0) ? 0 : DB_NOSYNC; DB **db = (DB**)object_handle(STACK_1,`BDB::DB`,OH_ADDRESS); if (*db) { - SYSCALL((*db)->close,(*db,flags)); - *db = NULL; + SYSCALL1((*db)->close,(*db,flags),{*db=NULL;}); VALUES1(T); } else VALUES1(NIL); skipSTACK(2); <at> <at> -758,30 +775,117 <at> <at> return obj; } -/* fill a DBT with contents of obj (a byte vector) +typedef enum { DBT_RAW, DBT_STRING, DBT_INTEGER } dbt_o_t; +/* check that the argument is a valis dbt_o_t specifier can trigger GC */ -static void fill_dbt (object obj, DBT* key) +static dbt_o_t check_dbt_type (object obj) { + restart_check_dbt_type: + if (missingp(obj) || eq(obj,`:RAW`)) return DBT_RAW; + if (eq(obj,`:STRING`)) return DBT_STRING; + if (eq(obj,`:INTEGER`)) return DBT_INTEGER; + pushSTACK(NIL); /* no PLACE */ + pushSTACK(obj); /* TYPE-ERROR slot DATUM */ + pushSTACK(`(MEMBER :RAW :STRING :INTEGER)`); /*EXPECTED-TYPE*/ + pushSTACK(`:RAW`); pushSTACK(`:STRING`); pushSTACK(`:INTEGER`); + pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); + check_value(type_error,GETTEXT("~S: ~S is neither ~S, ~S nor ~S")); + obj = value1; + goto restart_check_dbt_type; +} +/* check that the argument can be converted to a DBT + can trigger GC */ +static object check_dbt_object (object obj) { + while (!bit_vector_p(Atype_8Bit,obj) && !stringp(obj) + && !(integerp(obj) && positivep(obj))) { + pushSTACK(NIL); /* no PLACE */ + pushSTACK(obj); /* TYPE-ERROR slot DATUM */ + pushSTACK(`(OR STRING (INTEGER 0) (VECTOR (UNSIGNED-BYTE)))`);/*EXPECTED-TYPE*/ + pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); + check_value(type_error,GETTEXT("~S: ~S is neither string, nonnegative integer nor byte vector")); + obj = value1; + } + return obj; +} + +/* fill a DBT with contents of obj (a byte vector, string, or positive integer) + can trigger GC */ +static void fill_dbt (object obj, DBT* key, dbt_o_t *dbt_type) { unsigned long idx = 0; - obj = check_byte_vector(obj,-1); - init_dbt(key,DB_DBT_USERMEM); - key->ulen = key->size = vector_length(obj); - obj = array_displace_check(obj,key->size,&idx); - key->data = TheSbvector(obj)->data + idx; + obj = check_dbt_object(obj); + init_dbt(key,DB_DBT_MALLOC); + if (stringp(obj)) { + with_string_0(obj,GLO(misc_encoding),linez, { + key->ulen = key->size = linez_bytelen; + key->data = my_malloc(linez_bytelen); + begin_system_call(); + memcpy(key->data,linez,linez_bytelen); + end_system_call(); + }); + if (dbt_type) *dbt_type = DBT_STRING; + } else if (bit_vector_p(Atype_8Bit,obj)) { + key->ulen = key->size = vector_length(obj); + obj = array_displace_check(obj,key->size,&idx); + key->data = my_malloc(key->size); + begin_system_call(); + memcpy(key->data,TheSbvector(obj)->data + idx,key->size); + end_system_call(); + if (dbt_type) *dbt_type = DBT_RAW; + } else if (fixnump(obj)) { + key->ulen = key->size = sizeof(uintL); + key->data = my_malloc(key->size); + *(uintL*)key->data = posfixnum_to_L(obj); + if (dbt_type) *dbt_type = DBT_INTEGER; + } else if (bignump(obj)) { + key->ulen = key->size = sizeof(uintD)*Bignum_length(obj); + key->data = my_malloc(key->size); + begin_system_call(); + memcpy(key->data,TheBignum(obj)->data,key->size); + end_system_call(); + if (dbt_type) *dbt_type = DBT_INTEGER; + } else NOTREACHED; +} +static void free_dbt(DBT* dbt) { + begin_system_call(); free(dbt->data); end_system_call(); } /* convert a DBT to a byte vector can trigger GC */ -static object dbt_to_vector (DBT *p_dbt) +static object dbt_to_object (DBT *p_dbt, dbt_o_t type) { object vec; if (p_dbt->data == NULL) return NIL; - vec = allocate_bit_vector(Atype_8Bit,p_dbt->size); - begin_system_call(); - memcpy(TheSbvector(vec)->data,p_dbt->data,p_dbt->size); - free(p_dbt->data); - end_system_call(); - return vec; + switch (type) { + case DBT_RAW: + vec = allocate_bit_vector(Atype_8Bit,p_dbt->size); + begin_system_call(); + memcpy(TheSbvector(vec)->data,p_dbt->data,p_dbt->size); + free(p_dbt->data); + end_system_call(); + return vec; + case DBT_STRING: + return n_char_to_string(p_dbt->data,p_dbt->size,GLO(misc_encoding)); + case DBT_INTEGER: + if (p_dbt->size > sizeof(uintL)) { + uintL bn_size = ceiling(p_dbt->size,sizeof(uintD)); + uintD total = bn_size * sizeof(uintD); + object num = allocate_bignum(bn_size,0); + begin_system_call(); + memset(TheBignum(num)->data,0,total); + memcpy(TheBignum(num)->data + total - p_dbt->size, + p_dbt->data,p_dbt->size); + end_system_call(); + return num; + } else if (p_dbt->size == sizeof(uintL)) { + return UL_to_I(*(uintL*)p_dbt->data); + } else { + uintL res = 0, i; + for (i=0; i < p_dbt->size; i++) + res += ((char*)p_dbt->data)[i] << i; + return UL_to_I(res); + } + default: NOTREACHED; + } } <at> <at> -791,8 +895,8 <at> <at> DB_TXN *txn = object_handle(STACK_1,`BDB::TXN`,OH_NIL_IS_NULL); DB *db = object_handle(STACK_3,`BDB::DB`,OH_VALID); DBT key; - fill_dbt(STACK_2,&key); - SYSCALL(db->del,(db,txn,&key,flags)); + fill_dbt(STACK_2,&key,NULL); + SYSCALL1(db->del,(db,txn,&key,flags),{free(key.data);}); skipSTACK(4); VALUES0; } <at> <at> -808,19 +912,20 <at> <at> DEFCHECKER(db_get_action, DB_CONSUME DB_CONSUME_WAIT DB_GET_BOTH DB_SET_RECNO) DEFFLAGSET(db_get_options, DB_AUTO_COMMIT DB_DIRTY_READ DB_MULTIPLE DB_RMW) DEFUN(BDB:DB-GET, db key &key :ACTION :AUTO_COMMIT :DIRTY_READ :MULTIPLE :RMW \ - :TRANSACTION :ERROR) + :TRANSACTION :ERROR :TYPE) { /* Get items from a database */ + dbt_o_t out_type = check_dbt_type(popSTACK()); int no_error = nullp(popSTACK()); DB_TXN *txn = object_handle(popSTACK(),`BDB::TXN`,OH_NIL_IS_NULL); u_int32_t flags = db_get_options() | db_get_action(popSTACK()); DB *db = object_handle(STACK_1,`BDB::DB`,OH_VALID); DBT key, val; int status; - fill_dbt(STACK_0,&key); + fill_dbt(STACK_0,&key,NULL); init_dbt(&val,DB_DBT_MALLOC); skipSTACK(2); begin_system_call(); - status = db->get(db,txn,&key,&val,flags); + status = db->get(db,txn,&key,&val,flags); free(key.data); end_system_call(); if (status) { if (no_error) { <at> <at> -831,7 +936,8 <at> <at> } error_bdb(status,"db->get"); } - VALUES1(dbt_to_vector(&val)); + VALUES1(dbt_to_object(&val,out_type)); + free_dbt(&val); } DEFUN(BDB:DB-STAT, db &key :FAST_STAT) <at> <at> -947,7 +1053,9 <at> <at> int mode = posfixnum_default2(popSTACK(),0644); DBTYPE db_type = check_dbtype(popSTACK()); DB *db = object_handle(STACK_2,`BDB::DB`,OH_VALID); - with_string_0(physical_namestring(STACK_1),GLO(pathname_encoding),file, { + /* string is resolved by Berkeley-DB relative to data_dirs */ + with_string_0(stringp(STACK_1) ? STACK_1 : physical_namestring(STACK_1), + GLO(pathname_encoding),file, { if (missingp(STACK_0)) { /* no :DATABASE */ SYSCALL(db->open,(db,txn,file,NULL,db_type,flags,mode)); } else { /* multiple databases in one file */ <at> <at> -1020,9 +1128,9 <at> <at> DBT key, val; if (!missingp(STACK_0)) flags |= DB_AUTO_COMMIT; skipSTACK(1); - fill_dbt(STACK_0,&val); - fill_dbt(STACK_1,&key); - SYSCALL(db->put,(db,txn,&key,&val,flags)); + fill_dbt(STACK_0,&val,NULL); + fill_dbt(STACK_1,&key,NULL); + SYSCALL1(db->put,(db,txn,&key,&val,flags),{free(val.data);free(key.data);}); VALUES0; skipSTACK(3); } <at> <at> -1060,8 +1168,8 <at> <at> DBT key; DB_KEY_RANGE key_range; DB *db = object_handle(STACK_1,`BDB::DB`,OH_VALID); - fill_dbt(STACK_0,&key); - SYSCALL(db->key_range,(db,txn,&key,&key_range,0)); + fill_dbt(STACK_0,&key,NULL); + SYSCALL1(db->key_range,(db,txn,&key,&key_range,0),{free(key.data);}); pushSTACK(c_double_to_DF((dfloatjanus*)&(key_range.less))); pushSTACK(c_double_to_DF((dfloatjanus*)&(key_range.equal))); pushSTACK(c_double_to_DF((dfloatjanus*)&(key_range.greater))); <at> <at> -1161,11 +1269,11 <at> <at> } DEFUN(BDB:DB-SET-OPTIONS, db &key :ERRFILE :PASSWORD :ENCRYPTION \ - :NCACHE :CACHESIZE :LORDER :PAGESIZE \ + :NCACHE :CACHESIZE :LORDER :PAGESIZE :RE_LEN \ :CHKSUM :ENCRYPT :TXN_NOT_DURABLE :DUP :DUPSORT :RECNUM \ :REVSPLITOFF :RENUMBER :SNAPSHOT) { /* set database options */ - DB *db = object_handle(STACK_(14),`BDB::DB`,OH_VALID); + DB *db = object_handle(STACK_(17),`BDB::DB`,OH_VALID); { /* flags */ u_int32_t flags_on = 0, flags_off = 0; set_flags(popSTACK(),&flags_on,&flags_off,DB_SNAPSHOT); <at> <at> -1185,6 +1293,11 <at> <at> SYSCALL(db->set_flags,(db,flags)); } } + if (!missingp(STACK_0)) { /* RE_LEN */ + u_int32_t re_len = I_to_uint32(check_uint32(STACK_0)); + SYSCALL(db->set_re_len,(db,re_len)); + } + skipSTACK(1); if (!missingp(STACK_0)) { /* PAGESIZE */ u_int32_t pagesize = I_to_uint32(check_uint32(STACK_0)); SYSCALL(db->set_pagesize,(db,pagesize)); <at> <at> -1230,15 +1343,26 <at> <at> value2 = fixnum(ncache); } } -static object db_get_lorder (DB* db) { - int lorder; - SYSCALL(db->get_lorder,(db,&lorder)); - return fixnum(lorder); -} -static object db_get_pagesize (DB* db) { - u_int32_t pagesize; - SYSCALL(db->get_pagesize,(db,&pagesize)); - return UL_to_I(pagesize); +#define DEFINE_DB_GETTER(getter,type) \ + static object db_##getter (DB* db) { \ + type value; \ + SYSCALL(db->getter,(db,&value)); \ + return UL_to_I(value); \ + } +DEFINE_DB_GETTER(get_lorder,int) +DEFINE_DB_GETTER(get_pagesize,u_int32_t) +static object db_get_re_len (DB* db, int errorp) { + u_int32_t re_len; + int status; + begin_system_call(); + status = db->get_re_len(db,&re_len); + end_system_call(); + if (status) { + if (errorp) error_bdb(status,"db->get_re_len"); + error_message_reset(); + return NIL; + } else + return UL_to_I(re_len); } ERRFILE_FD_EXTRACTOR(db_get_errfile,DB*) FLAG_EXTRACTOR(db_get_flags_num,DB*) <at> <at> -1248,13 +1372,17 <at> <at> object what = STACK_0; skipSTACK(2); restart_DB_GET_OPTIONS: if (missingp(what)) { /* get everything */ - db_get_cache(db,false); pushSTACK(value1); pushSTACK(value2); - value1 = listof(2); pushSTACK(value1); - pushSTACK(db_get_errfile(db)); - value1 = db_get_flags_list(db); pushSTACK(value1); - pushSTACK(db_get_lorder(db)); - pushSTACK(db_get_pagesize(db)); - funcall(L(values),5); + uintL count = 0; + pushSTACK(`:CACHE`); db_get_cache(db,false); + pushSTACK(value1); pushSTACK(value2); value1 = listof(2); + pushSTACK(value1); count++; + pushSTACK(`:ERRFILE`); pushSTACK(db_get_errfile(db)); count++; + pushSTACK(`:FLAGS`); value1 = db_get_flags_list(db); + pushSTACK(value1); count++; + pushSTACK(`:LORDER`); pushSTACK(db_get_lorder(db)); count++; + pushSTACK(`:PAGESIZE`); pushSTACK(db_get_pagesize(db)); count++; + pushSTACK(`:RE_LEN`); pushSTACK(db_get_re_len(db,false)); count++; + VALUES1(listof(2*count)); } else if (eq(what,`:CACHE`)) { db_get_cache(db,true); mv_count = 2; } else if (eq(what,`:ENCRYPTION`)) { <at> <at> -1269,6 +1397,8 <at> <at> VALUES1(db_get_errfile(db)); } else if (eq(what,`:PAGESIZE`)) { VALUES1(db_get_pagesize(db)); + } else if (eq(what,`:RE_LEN`)) { + VALUES1(db_get_re_len(db,true)); } else if (eq(what,`:LORDER`)) { VALUES1(db_get_lorder(db)); } else if (eq(what,`:FLAGS`)) { <at> <at> -1316,8 +1446,7 <at> <at> { /* close a cursor */ DBC **cursor = (DBC**)object_handle(popSTACK(),`BDB::CURSOR`,OH_ADDRESS); if (*cursor) { - SYSCALL((*cursor)->c_close,(*cursor)); - *cursor = NULL; + SYSCALL1((*cursor)->c_close,(*cursor),{*cursor=NULL;}); VALUES1(T); } else VALUES1(NIL); } <at> <at> -1361,16 +1490,22 <at> <at> u_int32_t flag = cursor_get_options() | cursor_get_action(popSTACK()); DBC *cursor = object_handle(STACK_2,`BDB::CURSOR`,OH_VALID); DBT key, val; + dbt_o_t key_type, val_type; int status; - if (!nullp(STACK_1)) fill_dbt(STACK_1,&key); - else init_dbt(&key,DB_DBT_MALLOC); - if (!nullp(STACK_0)) fill_dbt(STACK_0,&val); - else init_dbt(&val,DB_DBT_MALLOC); + if (symbolp(STACK_1)) { /* type spec for the return value */ + key_type = check_dbt_type(STACK_1); + init_dbt(&key,DB_DBT_MALLOC); + } else fill_dbt(STACK_1,&key,&key_type); /* datum */ + if (symbolp(STACK_0)) { /* type spec for the return value */ + val_type = check_dbt_type(STACK_0); + init_dbt(&val,DB_DBT_MALLOC); + } else fill_dbt(STACK_0,&val,&val_type); /* datum */ skipSTACK(3); begin_system_call(); status = cursor->c_get(cursor,&key,&val,flag); end_system_call(); if (status) { + free_dbt(&key); free_dbt(&val); if (no_error) { switch (status) { case DB_NOTFOUND: VALUES1(`:NOTFOUND`); error_message_reset(); return; <at> <at> -1379,10 +1514,11 <at> <at> } error_bdb(status,"cursor->c_get"); } - pushSTACK(dbt_to_vector(&key)); - value2 = dbt_to_vector(&val); + pushSTACK(dbt_to_object(&key,key_type)); + value2 = dbt_to_object(&val,val_type); value1 = popSTACK(); mv_count = 2; + free_dbt(&key); free_dbt(&val); } DEFCHECKER(cursor_put_flag, DB_AFTER DB_BEFORE DB_CURRENT DB_KEYFIRST \ <at> <at> -1392,9 +1528,10 <at> <at> u_int32_t flag = cursor_put_flag(popSTACK()); DBC *cursor = object_handle(STACK_2,`BDB::CURSOR`,OH_VALID); DBT key, val; - fill_dbt(STACK_1,&key); - fill_dbt(STACK_0,&val); - SYSCALL(cursor->c_put,(cursor,&key,&val,flag)); + fill_dbt(STACK_1,&key,NULL); + fill_dbt(STACK_0,&val,NULL); + SYSCALL1(cursor->c_put,(cursor,&key,&val,flag), + {free(val.data);free(key.data);}); skipSTACK(3); VALUES0; } <at> <at> -1409,31 +1546,36 <at> <at> DB_TXN *parent = object_handle(popSTACK(),`BDB::TXN`,OH_NIL_IS_NULL), *ret; DB_ENV *dbe = object_handle(popSTACK(),`BDB::ENV`,OH_VALID); SYSCALL(dbe->txn_begin,(dbe,parent,&ret,flags)); - pushSTACK(allocate_fpointer(ret)); - funcall(`BDB::MKTXN`,1); + wrap_finalize(ret,&`BDB::MKTXN`,&``BDB::TXN-DISCARD``); /* ?? ABORT ?? */ } DEFUN(BDB:TXN-ABORT, txn) { /* Abort a transaction */ - DB_TXN *txn = object_handle(popSTACK(),`BDB::TXN`,OH_VALID); - SYSCALL(txn->abort,(txn)); - VALUES0; + DB_TXN **txn = (DB_TXN **)object_handle(popSTACK(),`BDB::TXN`,OH_ADDRESS); + if (*txn) { + SYSCALL1((*txn)->abort,(*txn),{*txn=NULL;}); + VALUES1(T); + } else VALUES1(NIL); } -DEFFLAGSET(txn_commit_flags, DB_TXN_NOSYNC DB_TXN_SYNC) -DEFUN(BDB:TXN-COMMIT, txn &key :NOSYNC :SYNC) +DEFCHECKER(txn_check_sync, DB_TXN_NOSYNC DB_TXN_SYNC) +DEFUN(BDB:TXN-COMMIT, txn &key :SYNC) { /* Commit a transaction */ - u_int32_t flags = txn_commit_flags(); - DB_TXN *txn = object_handle(popSTACK(),`BDB::TXN`,OH_VALID); - SYSCALL(txn->commit,(txn,flags)); - VALUES0; + u_int32_t flags = txn_check_sync(popSTACK()); + DB_TXN **txn = (DB_TXN **)object_handle(popSTACK(),`BDB::TXN`,OH_ADDRESS); + if (*txn) { + SYSCALL1((*txn)->commit,(*txn,flags),{*txn=NULL;}); + VALUES1(T); + } else VALUES1(NIL); } DEFUN(BDB:TXN-DISCARD, txn) { /* Discard a transaction */ - DB_TXN *txn = object_handle(popSTACK(),`BDB::TXN`,OH_VALID); - SYSCALL(txn->discard,(txn,0)); - VALUES0; + DB_TXN **txn = (DB_TXN **)object_handle(popSTACK(),`BDB::TXN`,OH_ADDRESS); + if (*txn) { + SYSCALL1((*txn)->discard,(*txn,0),{*txn=NULL;}); + VALUES1(T); + } else VALUES1(NIL); } DEFUN(BDB:TXN-ID, txn) Index: berkeley-db.xml =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/berkeley-db.xml,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- berkeley-db.xml 28 Jun 2004 16:03:59 -0000 1.16 +++ berkeley-db.xml 1 Jul 2004 15:15:35 -0000 1.17 <at> <at> -62,7 +62,7 <at> <at> <listitem><para>Retrieve some environment options. <variablelist><title>Values of <replaceable>what</replaceable></title> <varlistentry><term>missing</term><term>&nil;</term> - <listitem><simpara>all options as multiple values + <listitem><simpara>all options as a &list-t; </simpara></listitem></varlistentry> <varlistentry><term><constant>:TX_TIMESTAMP</constant></term> <listitem><simpara>Recover to the time specified by timestamp <at> <at> -238,15 +238,17 <at> <at> --> <variablelist> <varlistentry><term><literal role="sexp">(BDB:DB-SET-OPTIONS db &key-amp; - ERRFILE PASSWORD ENCRYPT NCACHE CACHESIZE)</literal></term> + ERRFILE PASSWORD ENCRYPT NCACHE CACHESIZE PAGESIZE RE_LEN LORDER) + </literal></term> <listitem><simpara>Call &DB_set_errfile;, &DB_set_encrypt;, - &DB_set_cachesize;.</simpara></listitem></varlistentry> -<varlistentry><term><literal role="sexp">(BDB:ENV-GET-OPTIONS dbe + &DB_set_cachesize;, &DB_set_re_len;, &DB_set_pagesize;, &DB_set_lorder;. +</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:DB-GET-OPTIONS db &optional-amp; what)</literal></term> - <listitem><para>Retrieve some environment options. + <listitem><para>Retrieve some database options. <variablelist><title>Values of <replaceable>what</replaceable></title> <varlistentry><term>missing</term><term>&nil;</term> - <listitem><simpara>all options as multiple values + <listitem><simpara>all options as a &list-t; </simpara></listitem></varlistentry> <varlistentry><term><constant>:FLAGS</constant></term> <listitem><simpara>all flags (&DBE_get_flags;). <at> <at> -267,7 +269,16 <at> <at> <listitem><simpara>encryption flags (&DBE_get_encrypt_flags;). </simpara></listitem></varlistentry> <varlistentry><term><constant>:ERRFILE</constant></term> - <listitem><simpara>&file-des; or &nil; (&DBE_get_errfile;). + <listitem><simpara>&file-des; or &nil; (&DB_get_errfile;). + </simpara></listitem></varlistentry> + <varlistentry><term><constant>:PAGESIZE</constant></term> + <listitem><simpara>database page size (&DB_get_pagesize;). + </simpara></listitem></varlistentry> + <varlistentry><term><constant>:CACHESIZE</constant></term> + <listitem><simpara>database cache size (&DB_get_cachesize;). + </simpara></listitem></varlistentry> + <varlistentry><term><constant>:LORDER</constant></term> + <listitem><simpara>database byte orderb (&DB_get_lorder;). </simpara></listitem></varlistentry> </variablelist></para></listitem></varlistentry> </variablelist> Index: test.tst =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/test.tst,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- test.tst 29 Jun 2004 15:30:58 -0000 1.1 +++ test.tst 1 Jul 2004 15:15:35 -0000 1.2 <at> <at> -24,9 +24,16 <at> <at> (ext:make-dir name)) NIL) prepare-dir +(defun show-db (db) + (let ((*print-pretty* t)) + (print (list db (bdb:db-fd db) (bdb:db-stat db) + (bdb:db-get-options db)))) + nil) +show-db (prepare-dir "bdb-home/") NIL (prepare-dir "bdb-data/") NIL +(null (delete-file "bdb-errors")) NIL ;;; creation <at> <at> -36,30 +43,49 <at> <at> :data_dir "bdb-data/") NIL -(progn (print (multiple-value-list (bdb:env-get-options *dbe*))) nil) NIL +(progn (print (bdb:env-get-options *dbe*)) nil) NIL (bdb:env-open *dbe* :home "bdb-home/" :create t :init_mpool t) NIL -(progn (print (multiple-value-list (bdb:env-get-options *dbe*))) nil) NIL +(progn (print (bdb:env-get-options *dbe*)) nil) NIL (defvar *db* (print (bdb:db-create *dbe*))) *db* -(bdb:db-open *db* "bdb-data/bazonk.db" :type :BTREE :create t) NIL +;; the actual file goes to ./bdb-data/bazonk.db ! +(bdb:db-open *db* "bazonk.db" :type :BTREE :create t) NIL -(bdb:db-put *db* (ext:convert-string-to-bytes "foo" charset:utf-8) - (ext:convert-string-to-bytes "bar" charset:utf-8)) +(null (probe-file "./bdb-data/bazonk.db")) NIL + +(bdb:db-put *db* "foo" "bar") NIL -(bdb:db-put *db* (ext:convert-string-to-bytes "fep" charset:utf-8) - (ext:convert-string-to-bytes "blicket" charset:utf-8)) +(bdb:db-put *db* "fep" "blicket") NIL (bdb:db-sync *db*) NIL +(show-db *db*) NIL +(bdb:db-close *db*) T -(integerp (print (bdb:db-fd *db*))) T -(progn (print (multiple-value-list (bdb:db-get-options *db*))) nil) NIL -(progn (print (bdb:db-stat *db*)) nil) nil +(dolist (type '(:btree :hash)) + (print type) + (bdb:with-open-db (db *dbe* (format nil "test-~A.db" type) + :type type :create t) + (show-db db) + (dotimes (i 25) (bdb:db-put db i (! i))))) +NIL + +(dolist (type '(:queue :recno)) + (print type) + (let ((db (bdb:db-create *dbe*))) + ;; :RE_LEN must be set before DB-OPEN + (bdb:db-set-options db :RE_LEN (print (integer-length (! 25)))) + (bdb:db-open db (format nil "test-~A.db" type) :type type :create t) + (show-db db) + (unwind-protect + (dotimes (i 25) (bdb:db-put db i (! i) :flag :DB_APPEND)) + (bdb:db-close db)) + (print db))) +NIL -(bdb:db-close *db*) T (bdb:env-close *dbe*) T (ext:dir "bdb-home/*") NIL <at> <at> -80,39 +106,46 <at> <at> (bdb:env-open *dbe* :home "bdb-home/" :create t :init_mpool t) NIL -(progn (print (multiple-value-list (bdb:env-get-options *dbe*))) nil) NIL +(progn (print (bdb:env-get-options *dbe*)) nil) NIL (progn (setq *db* (print (bdb:db-create *dbe*))) nil) NIL -(bdb:db-open *db* "bdb-data/bazonk.db" :rdonly t) NIL +(bdb:db-open *db* "bazonk.db" :rdonly t) NIL -(integerp (print (bdb:db-fd *db*))) T -(progn (print (multiple-value-list (bdb:db-get-options *db*))) nil) NIL -(progn (print (bdb:db-stat *db*)) nil) nil +(show-db *db*) NIL (defvar *cursor* (print (bdb:make-cursor *db*))) *cursor* (let ((li ())) (loop (multiple-value-bind (key val) - (bdb:cursor-get *cursor* nil nil :DB_NEXT :error nil) + (bdb:cursor-get *cursor* :STRING :STRING :DB_NEXT :error nil) (when (eq key :notfound) (return li)) - (setq key (ext:convert-string-from-bytes key charset:utf-8) - val (ext:convert-string-from-bytes val charset:utf-8)) (format t "~&=[count=~D]=> ~S -> ~S~%" (bdb:cursor-count *cursor*) key val) (push (list key val) li)))) (("foo" "bar") ("fep" "blicket")) -(bdb:db-get *db* (ext:convert-string-to-bytes "bar" charset:utf-8) :error nil) +(bdb:db-get *db* "bar" :error nil :type :raw) :NOTFOUND -(ext:convert-string-from-bytes - (bdb:db-get *db* (ext:convert-string-to-bytes "foo" charset:utf-8)) - charset:utf-8) -"bar" +(bdb:db-get *db* "foo") +#(98 97 114) ; "bar" (bdb:cursor-close *cursor*) T (bdb:db-close *db*) T + +(dolist (type '(:btree :hash :queue :recno)) + (print type) + (bdb:with-open-db (db *dbe* (format nil "test-~A.db" type)) + (show-db db) + (bdb:with-cursor (cu db) + (loop (multiple-value-bind (key val) + (bdb:cursor-get cu :INTEGER :INTEGER :DB_NEXT :error nil) + (when (eq key :notfound) (return)) + (format t "~&=[count=~D]=> ~S -> ~S~%" + (bdb:cursor-count cu) key val)))))) +NIL + (bdb:env-close *dbe*) T (with-open-file (e "bdb-errors" :direction :input) Index: dbi.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/dbi.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- dbi.lisp 29 Jun 2004 15:30:58 -0000 1.10 +++ dbi.lisp 1 Jul 2004 15:15:35 -0000 1.11 <at> <at> -18,7 +18,7 <at> <at> "TXN-CHECKPOINT" "TXN-PREPARE" "TXN-RECOVER" "TXN-SET-TIMEOUT" "TXN-STAT" "BDB-ERROR" "BDB-ERROR-NUMBER" - "WITH-OPEN-DB")) + "WITH-OPEN-DB" "WITH-CURSOR")) (setf (package-lock "EXT") nil) (use-package '("BDB") "EXT") <at> <at> -154,12 +154,21 <at> <at> (txnarray nil :type vector :read-only t)) ;;; macros (see macros2.lisp for `with-open-file') -(defmacro with-open-db ((var &rest options) &body forms) +(defmacro with-open-db ((var dbe file &rest options &key xa &allow-other-keys) + &body forms) (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY forms) - `(LET ((,var (BDB:DB-OPEN , <at> options))) + (remf options :xa) + `(LET ((,var (BDB:DB-CREATE ,dbe :xa ,xa))) (DECLARE (READ-ONLY ,var) , <at> declarations) + (BDB:DB-OPEN ,var ,file , <at> options) (UNWIND-PROTECT (PROGN , <at> body-rest) (WHEN ,var (BDB:DB-CLOSE ,var)))))) +(defmacro with-cursor ((var &rest options) &body forms) + (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY forms) + `(LET ((,var (BDB:MAKE-CURSOR , <at> options))) + (DECLARE (READ-ONLY ,var) , <at> declarations) + (UNWIND-PROTECT (PROGN , <at> body-rest) + (WHEN ,var (BDB:CURSOR-CLOSE ,var)))))) (ext:without-package-lock ("CL") (defmethod close ((dbe env) &key abort) <at> <at> -171,6 +180,8 <at> <at> (defmethod close ((cu cursor) &key abort) (declare (ignore abort)) (cursor-close cu)) +(defmethod close ((tx txn) &key abort) + (if abort (txn-abort tx) (txn-discard tx))) ) (define-condition bdb-error (simple-error) --__--__-- _______________________________________________ clisp-cvs mailing list clisp-cvs <at> lists.sourceforge.net https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest ------------------------------------------------------- This SF.Net email sponsored by Black Hat Briefings & Training. Attend Black Hat Briefings & Training, Las Vegas July 24-29 - digital self defense, top technical experts, no vendor pitches, unmatched networking opportunities. Visit www.blackhat.com
RSS Feed