Mercurial > hg > xemacs-beta
annotate src/database.c @ 5117:3742ea8250b5 ben-lisp-object ben-lisp-object-final-ws-year-2005
Checking in final CVS version of workspace 'ben-lisp-object'
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 26 Dec 2009 00:20:27 -0600 |
| parents | 4c038e89d563 |
| children | e0db3c197671 |
| rev | line source |
|---|---|
| 428 | 1 /* Database access routines |
| 2 Copyright (C) 1996, William M. Perry | |
| 3025 | 3 Copyright (C) 2001, 2002, 2005 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
| 7 XEmacs is free software; you can redistribute it and/or modify it | |
| 8 under the terms of the GNU General Public License as published by the | |
| 9 Free Software Foundation; either version 2, or (at your option) any | |
| 10 later version. | |
| 11 | |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
| 18 along with XEmacs; see the file COPYING. If not, write to | |
| 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 20 Boston, MA 02111-1307, USA. */ | |
| 21 | |
| 22 /* Synched up with: Not in FSF. */ | |
| 23 | |
| 24 /* Written by Bill Perry */ | |
| 25 /* Substantially rewritten by Martin Buchholz */ | |
| 26 /* db 2.x support added by Andreas Jaeger */ | |
| 771 | 27 /* Mule-ized 6-22-00 Ben Wing */ |
| 428 | 28 |
| 29 #include <config.h> | |
| 30 #include "lisp.h" | |
| 771 | 31 |
| 428 | 32 #include "sysfile.h" |
| 33 #include "buffer.h" | |
| 34 | |
| 35 #ifndef HAVE_DATABASE | |
| 36 #error HAVE_DATABASE not defined!! | |
| 37 #endif | |
| 38 | |
| 39 #include "database.h" /* Our include file */ | |
| 40 | |
| 41 #ifdef HAVE_BERKELEY_DB | |
| 42 /* Work around Berkeley DB's use of int types which are defined | |
| 43 slightly differently in the not quite yet standard <inttypes.h>. | |
| 44 See db.h for details of why we're resorting to this... */ | |
| 45 /* glibc 2.1 doesn't have this problem with DB 2.x */ | |
| 46 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) | |
| 47 #ifdef HAVE_INTTYPES_H | |
| 48 #define __BIT_TYPES_DEFINED__ | |
| 49 #include <inttypes.h> | |
| 3072 | 50 #if !defined(__FreeBSD__) && !defined(__NetBSD__) && !defined(__APPLE__) |
| 428 | 51 typedef uint8_t u_int8_t; |
| 52 typedef uint16_t u_int16_t; | |
| 53 typedef uint32_t u_int32_t; | |
| 54 #ifdef WE_DONT_NEED_QUADS | |
| 55 typedef uint64_t u_int64_t; | |
| 56 #endif /* WE_DONT_NEED_QUADS */ | |
| 1453 | 57 #endif /* __FreeBSD__ */ |
| 428 | 58 #endif /* HAVE_INTTYPES_H */ |
| 59 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */ | |
| 1460 | 60 /* Berkeley DB wants __STDC__ to be defined; else if does `#define const' */ |
| 61 #if ! defined (__STDC__) && ! defined(__cplusplus) | |
| 62 #define __STDC__ 0 | |
| 63 #endif | |
| 442 | 64 #include DB_H_FILE /* Berkeley db's header file */ |
| 428 | 65 #ifndef DB_VERSION_MAJOR |
| 66 # define DB_VERSION_MAJOR 1 | |
| 67 #endif /* DB_VERSION_MAJOR */ | |
| 1141 | 68 #ifndef DB_VERSION_MINOR |
| 69 # define DB_VERSION_MINOR 0 | |
| 70 #endif /* DB_VERSION_MINOR */ | |
| 428 | 71 Lisp_Object Qberkeley_db; |
| 72 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown; | |
| 448 | 73 #if DB_VERSION_MAJOR > 2 |
| 74 Lisp_Object Qqueue; | |
| 75 #endif | |
| 428 | 76 #endif /* HAVE_BERKELEY_DB */ |
| 77 | |
| 78 #ifdef HAVE_DBM | |
| 79 #include <ndbm.h> | |
| 80 Lisp_Object Qdbm; | |
| 81 #endif /* HAVE_DBM */ | |
| 82 | |
| 83 Lisp_Object Vdatabase_coding_system; | |
| 84 | |
| 85 Lisp_Object Qdatabasep; | |
| 86 | |
| 87 typedef struct | |
| 88 { | |
| 89 Lisp_Object (*get_subtype) (Lisp_Database *); | |
| 90 Lisp_Object (*get_type) (Lisp_Database *); | |
| 91 Lisp_Object (*get) (Lisp_Database *, Lisp_Object); | |
| 92 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); | |
| 93 int (*rem) (Lisp_Database *, Lisp_Object); | |
| 94 void (*map) (Lisp_Database *, Lisp_Object); | |
| 95 void (*close) (Lisp_Database *); | |
| 96 Lisp_Object (*last_error) (Lisp_Database *); | |
| 97 } DB_FUNCS; | |
| 98 | |
| 99 struct Lisp_Database | |
| 100 { | |
| 3017 | 101 struct LCRECORD_HEADER header; |
| 428 | 102 Lisp_Object fname; |
| 103 int mode; | |
| 104 int access_; | |
| 105 int dberrno; | |
| 106 int live_p; | |
| 107 #ifdef HAVE_DBM | |
| 108 DBM *dbm_handle; | |
| 109 #endif | |
| 110 #ifdef HAVE_BERKELEY_DB | |
| 111 DB *db_handle; | |
| 112 #endif | |
| 113 DB_FUNCS *funcs; | |
| 114 Lisp_Object coding_system; | |
| 115 }; | |
| 116 | |
| 117 #define XDATABASE(x) XRECORD (x, database, Lisp_Database) | |
| 617 | 118 #define wrap_database(p) wrap_record (p, database) |
| 428 | 119 #define DATABASEP(x) RECORDP (x, database) |
| 120 #define CHECK_DATABASE(x) CHECK_RECORD (x, database) | |
| 121 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database) | |
| 122 #define DATABASE_LIVE_P(x) (x->live_p) | |
| 123 | |
| 124 #define CHECK_LIVE_DATABASE(db) do { \ | |
| 125 CHECK_DATABASE (db); \ | |
| 126 if (!DATABASE_LIVE_P (XDATABASE(db))) \ | |
| 563 | 127 invalid_operation ("Attempting to access closed database", db); \ |
| 428 | 128 } while (0) |
| 129 | |
| 130 | |
| 131 static Lisp_Database * | |
| 132 allocate_database (void) | |
| 133 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
134 Lisp_Object obj = ALLOC_LISP_OBJECT (database); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
135 Lisp_Database *db = XDATABASE (obj); |
| 428 | 136 |
| 137 db->fname = Qnil; | |
| 138 db->live_p = 0; | |
| 139 #ifdef HAVE_BERKELEY_DB | |
| 140 db->db_handle = NULL; | |
| 141 #endif | |
| 142 #ifdef HAVE_DBM | |
| 143 db->dbm_handle = NULL; | |
| 144 #endif | |
| 145 db->access_ = 0; | |
| 146 db->mode = 0; | |
| 147 db->dberrno = 0; | |
| 771 | 148 db->coding_system = Qnil; |
| 428 | 149 return db; |
| 150 } | |
| 151 | |
| 1204 | 152 static const struct memory_description database_description[] = { |
| 934 | 153 { XD_LISP_OBJECT, offsetof (struct Lisp_Database, fname) }, |
| 154 { XD_END} | |
| 155 }; | |
| 156 | |
| 428 | 157 static Lisp_Object |
| 444 | 158 mark_database (Lisp_Object object) |
| 428 | 159 { |
| 444 | 160 Lisp_Database *db = XDATABASE (object); |
| 428 | 161 return db->fname; |
| 162 } | |
| 163 | |
| 164 static void | |
| 2286 | 165 print_database (Lisp_Object obj, Lisp_Object printcharfun, |
| 166 int UNUSED (escapeflag)) | |
| 428 | 167 { |
| 168 Lisp_Database *db = XDATABASE (obj); | |
| 169 | |
| 170 if (print_readably) | |
| 563 | 171 printing_unreadable_object ("#<database 0x%x>", db->header.uid); |
| 428 | 172 |
| 793 | 173 write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", |
| 174 3, db->fname, db->funcs->get_type (db), | |
| 175 db->funcs->get_subtype (db)); | |
| 176 | |
| 177 write_fmt_string (printcharfun, "%s) 0x%x>", | |
| 178 (!DATABASE_LIVE_P (db) ? "closed" : | |
| 179 (db->access_ & O_WRONLY) ? "writeonly" : | |
| 180 (db->access_ & O_RDWR) ? "readwrite" : "readonly"), | |
| 181 db->header.uid); | |
| 428 | 182 } |
| 183 | |
| 184 static void | |
| 185 finalize_database (void *header, int for_disksave) | |
| 186 { | |
| 187 Lisp_Database *db = (Lisp_Database *) header; | |
| 188 | |
| 189 if (for_disksave) | |
| 190 { | |
| 563 | 191 invalid_operation |
| 793 | 192 ("Can't dump an emacs containing database objects", |
| 193 wrap_database (db)); | |
| 428 | 194 } |
| 195 db->funcs->close (db); | |
| 196 } | |
| 197 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
198 DEFINE_NONDUMPABLE_LISP_OBJECT ("database", database, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
199 mark_database, print_database, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
200 finalize_database, 0, 0, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
201 database_description, |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
202 Lisp_Database); |
| 428 | 203 |
| 204 DEFUN ("close-database", Fclose_database, 1, 1, 0, /* | |
| 205 Close database DATABASE. | |
| 206 */ | |
| 207 (database)) | |
| 208 { | |
| 209 Lisp_Database *db; | |
| 210 CHECK_LIVE_DATABASE (database); | |
| 211 db = XDATABASE (database); | |
| 212 db->funcs->close (db); | |
| 213 db->live_p = 0; | |
| 214 return Qnil; | |
| 215 } | |
| 216 | |
| 217 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /* | |
| 218 Return the type of database DATABASE. | |
| 219 */ | |
| 220 (database)) | |
| 221 { | |
| 222 CHECK_DATABASE (database); | |
| 223 | |
| 224 return XDATABASE (database)->funcs->get_type (XDATABASE (database)); | |
| 225 } | |
| 226 | |
| 227 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /* | |
| 228 Return the subtype of database DATABASE, if any. | |
| 229 */ | |
| 230 (database)) | |
| 231 { | |
| 232 CHECK_DATABASE (database); | |
| 233 | |
| 234 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database)); | |
| 235 } | |
| 236 | |
| 237 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /* | |
| 444 | 238 Return t if OBJECT is an active database. |
| 428 | 239 */ |
| 444 | 240 (object)) |
| 428 | 241 { |
| 444 | 242 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ? |
| 243 Qt : Qnil; | |
| 428 | 244 } |
| 245 | |
| 246 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /* | |
| 247 Return the filename associated with the database DATABASE. | |
| 248 */ | |
| 249 (database)) | |
| 250 { | |
| 251 CHECK_DATABASE (database); | |
| 252 | |
| 253 return XDATABASE (database)->fname; | |
| 254 } | |
| 255 | |
| 256 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /* | |
| 444 | 257 Return t if OBJECT is a database. |
| 428 | 258 */ |
| 444 | 259 (object)) |
| 428 | 260 { |
| 444 | 261 return DATABASEP (object) ? Qt : Qnil; |
| 428 | 262 } |
| 263 | |
| 264 #ifdef HAVE_DBM | |
| 265 static void | |
| 266 dbm_map (Lisp_Database *db, Lisp_Object func) | |
| 267 { | |
| 268 datum keydatum, valdatum; | |
| 269 Lisp_Object key, val; | |
| 270 | |
| 271 for (keydatum = dbm_firstkey (db->dbm_handle); | |
| 272 keydatum.dptr != NULL; | |
| 273 keydatum = dbm_nextkey (db->dbm_handle)) | |
| 274 { | |
| 275 valdatum = dbm_fetch (db->dbm_handle, keydatum); | |
| 771 | 276 key = make_ext_string (keydatum.dptr, keydatum.dsize, |
| 277 db->coding_system); | |
| 278 val = make_ext_string (valdatum.dptr, valdatum.dsize, | |
| 279 db->coding_system); | |
| 428 | 280 call2 (func, key, val); |
| 281 } | |
| 282 } | |
| 283 | |
| 284 static Lisp_Object | |
| 285 dbm_get (Lisp_Database *db, Lisp_Object key) | |
| 286 { | |
| 287 datum keydatum, valdatum; | |
| 288 | |
| 771 | 289 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
| 290 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
| 291 db->coding_system); | |
| 428 | 292 valdatum = dbm_fetch (db->dbm_handle, keydatum); |
| 293 | |
| 294 return (valdatum.dptr | |
| 771 | 295 ? make_ext_string (valdatum.dptr, valdatum.dsize, |
| 296 db->coding_system) | |
| 428 | 297 : Qnil); |
| 298 } | |
| 299 | |
| 300 static int | |
| 301 dbm_put (Lisp_Database *db, | |
| 302 Lisp_Object key, Lisp_Object val, Lisp_Object replace) | |
| 303 { | |
| 304 datum keydatum, valdatum; | |
| 305 | |
| 771 | 306 TO_EXTERNAL_FORMAT (LISP_STRING, val, |
| 307 ALLOCA, (valdatum.dptr, valdatum.dsize), | |
| 308 db->coding_system); | |
| 309 TO_EXTERNAL_FORMAT (LISP_STRING, key, | |
| 310 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
| 311 db->coding_system); | |
| 428 | 312 |
| 313 return !dbm_store (db->dbm_handle, keydatum, valdatum, | |
| 314 NILP (replace) ? DBM_INSERT : DBM_REPLACE); | |
| 315 } | |
| 316 | |
| 317 static int | |
| 318 dbm_remove (Lisp_Database *db, Lisp_Object key) | |
| 319 { | |
| 320 datum keydatum; | |
| 321 | |
| 771 | 322 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
| 323 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
| 324 db->coding_system); | |
| 428 | 325 |
| 326 return dbm_delete (db->dbm_handle, keydatum); | |
| 327 } | |
| 328 | |
| 329 static Lisp_Object | |
| 2494 | 330 dbm_type (Lisp_Database *UNUSED (db)) |
| 428 | 331 { |
| 332 return Qdbm; | |
| 333 } | |
| 334 | |
| 335 static Lisp_Object | |
| 2494 | 336 dbm_subtype (Lisp_Database *UNUSED (db)) |
| 428 | 337 { |
| 338 return Qnil; | |
| 339 } | |
| 340 | |
| 341 static Lisp_Object | |
| 342 dbm_lasterr (Lisp_Database *db) | |
| 343 { | |
| 344 return lisp_strerror (db->dberrno); | |
| 345 } | |
| 346 | |
| 347 static void | |
| 348 dbm_closeit (Lisp_Database *db) | |
| 349 { | |
| 350 if (db->dbm_handle) | |
| 351 { | |
| 352 dbm_close (db->dbm_handle); | |
| 353 db->dbm_handle = NULL; | |
| 354 } | |
| 355 } | |
| 356 | |
| 357 static DB_FUNCS ndbm_func_block = | |
| 358 { | |
| 359 dbm_subtype, | |
| 360 dbm_type, | |
| 361 dbm_get, | |
| 362 dbm_put, | |
| 363 dbm_remove, | |
| 364 dbm_map, | |
| 365 dbm_closeit, | |
| 366 dbm_lasterr | |
| 367 }; | |
| 368 #endif /* HAVE_DBM */ | |
| 369 | |
| 370 #ifdef HAVE_BERKELEY_DB | |
| 371 static Lisp_Object | |
| 2286 | 372 berkdb_type (Lisp_Database *UNUSED (db)) |
| 428 | 373 { |
| 374 return Qberkeley_db; | |
| 375 } | |
| 376 | |
| 377 static Lisp_Object | |
| 378 berkdb_subtype (Lisp_Database *db) | |
| 379 { | |
| 380 if (!db->db_handle) | |
| 381 return Qnil; | |
| 382 | |
| 383 switch (db->db_handle->type) | |
| 384 { | |
| 385 case DB_BTREE: return Qbtree; | |
| 386 case DB_HASH: return Qhash; | |
| 387 case DB_RECNO: return Qrecno; | |
| 448 | 388 #if DB_VERSION_MAJOR > 2 |
| 389 case DB_QUEUE: return Qqueue; | |
| 390 #endif | |
| 428 | 391 default: return Qunknown; |
| 392 } | |
| 393 } | |
| 394 | |
| 395 static Lisp_Object | |
| 396 berkdb_lasterr (Lisp_Database *db) | |
| 397 { | |
| 398 return lisp_strerror (db->dberrno); | |
| 399 } | |
| 400 | |
| 401 static Lisp_Object | |
| 402 berkdb_get (Lisp_Database *db, Lisp_Object key) | |
| 403 { | |
| 404 DBT keydatum, valdatum; | |
| 405 int status = 0; | |
| 406 | |
| 407 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 408 xzero (keydatum); | |
| 409 xzero (valdatum); | |
| 410 | |
| 771 | 411 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
| 412 ALLOCA, (keydatum.data, keydatum.size), | |
| 413 db->coding_system); | |
| 428 | 414 |
| 415 #if DB_VERSION_MAJOR == 1 | |
| 416 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0); | |
| 417 #else | |
| 418 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0); | |
| 419 #endif /* DB_VERSION_MAJOR */ | |
| 420 | |
| 421 if (!status) | |
| 1645 | 422 return make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 423 db->coding_system); |
| 428 | 424 |
| 425 #if DB_VERSION_MAJOR == 1 | |
| 426 db->dberrno = (status == 1) ? -1 : errno; | |
| 427 #else | |
| 428 db->dberrno = (status < 0) ? -1 : errno; | |
| 429 #endif /* DB_VERSION_MAJOR */ | |
| 430 | |
| 431 return Qnil; | |
| 432 } | |
| 433 | |
| 434 static int | |
| 435 berkdb_put (Lisp_Database *db, | |
| 436 Lisp_Object key, | |
| 437 Lisp_Object val, | |
| 438 Lisp_Object replace) | |
| 439 { | |
| 440 DBT keydatum, valdatum; | |
| 441 int status = 0; | |
| 442 | |
| 443 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 444 xzero (keydatum); | |
| 445 xzero (valdatum); | |
| 446 | |
| 771 | 447 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
| 448 ALLOCA, (keydatum.data, keydatum.size), | |
| 449 db->coding_system); | |
| 450 TO_EXTERNAL_FORMAT (LISP_STRING, val, | |
| 451 ALLOCA, (valdatum.data, valdatum.size), | |
| 452 db->coding_system); | |
| 428 | 453 #if DB_VERSION_MAJOR == 1 |
| 454 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum, | |
| 455 NILP (replace) ? R_NOOVERWRITE : 0); | |
| 456 db->dberrno = (status == 1) ? -1 : errno; | |
| 457 #else | |
| 458 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum, | |
| 459 NILP (replace) ? DB_NOOVERWRITE : 0); | |
| 460 db->dberrno = (status < 0) ? -1 : errno; | |
| 461 #endif/* DV_VERSION_MAJOR = 2 */ | |
| 462 | |
| 463 return status; | |
| 464 } | |
| 465 | |
| 466 static int | |
| 467 berkdb_remove (Lisp_Database *db, Lisp_Object key) | |
| 468 { | |
| 469 DBT keydatum; | |
| 470 int status; | |
| 471 | |
| 472 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 473 xzero (keydatum); | |
| 474 | |
| 771 | 475 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
| 476 ALLOCA, (keydatum.data, keydatum.size), | |
| 477 db->coding_system); | |
| 428 | 478 |
| 479 #if DB_VERSION_MAJOR == 1 | |
| 480 status = db->db_handle->del (db->db_handle, &keydatum, 0); | |
| 481 #else | |
| 482 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0); | |
| 483 #endif /* DB_VERSION_MAJOR */ | |
| 484 | |
| 485 if (!status) | |
| 486 return 0; | |
| 487 | |
| 488 #if DB_VERSION_MAJOR == 1 | |
| 489 db->dberrno = (status == 1) ? -1 : errno; | |
| 490 #else | |
| 491 db->dberrno = (status < 0) ? -1 : errno; | |
| 492 #endif /* DB_VERSION_MAJOR */ | |
| 493 | |
| 494 return 1; | |
| 495 } | |
| 496 | |
| 497 static void | |
| 498 berkdb_map (Lisp_Database *db, Lisp_Object func) | |
| 499 { | |
| 500 DBT keydatum, valdatum; | |
| 501 Lisp_Object key, val; | |
| 502 DB *dbp = db->db_handle; | |
| 503 int status; | |
| 504 | |
| 505 xzero (keydatum); | |
| 506 xzero (valdatum); | |
| 507 | |
| 508 #if DB_VERSION_MAJOR == 1 | |
| 509 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); | |
| 510 status == 0; | |
| 511 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT)) | |
| 512 { | |
| 2646 | 513 key = make_ext_string ((const Extbyte *) keydatum.data, keydatum.size, |
| 771 | 514 db->coding_system); |
| 2646 | 515 val = make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 516 db->coding_system); |
| 428 | 517 call2 (func, key, val); |
| 518 } | |
| 519 #else | |
| 520 { | |
| 521 DBC *dbcp; | |
| 522 | |
| 523 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6 | |
| 524 status = dbp->cursor (dbp, NULL, &dbcp, 0); | |
| 525 #else | |
| 526 status = dbp->cursor (dbp, NULL, &dbcp); | |
| 440 | 527 #endif |
| 428 | 528 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); |
| 529 status == 0; | |
| 530 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT)) | |
| 531 { | |
| 1645 | 532 key = make_ext_string ((const Extbyte *) keydatum.data, keydatum.size, |
| 771 | 533 db->coding_system); |
| 1645 | 534 val = make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 535 db->coding_system); |
| 428 | 536 call2 (func, key, val); |
| 537 } | |
| 538 dbcp->c_close (dbcp); | |
| 539 } | |
| 540 #endif /* DB_VERSION_MAJOR */ | |
| 541 } | |
| 542 | |
| 543 static void | |
| 544 berkdb_close (Lisp_Database *db) | |
| 545 { | |
| 546 if (db->db_handle) | |
| 547 { | |
| 548 #if DB_VERSION_MAJOR == 1 | |
| 549 db->db_handle->sync (db->db_handle, 0); | |
| 550 db->db_handle->close (db->db_handle); | |
| 551 #else | |
| 552 db->db_handle->sync (db->db_handle, 0); | |
| 553 db->db_handle->close (db->db_handle, 0); | |
| 554 #endif /* DB_VERSION_MAJOR */ | |
| 555 db->db_handle = NULL; | |
| 556 } | |
| 557 } | |
| 558 | |
| 559 static DB_FUNCS berk_func_block = | |
| 560 { | |
| 561 berkdb_subtype, | |
| 562 berkdb_type, | |
| 563 berkdb_get, | |
| 564 berkdb_put, | |
| 565 berkdb_remove, | |
| 566 berkdb_map, | |
| 567 berkdb_close, | |
| 568 berkdb_lasterr | |
| 569 }; | |
| 570 #endif /* HAVE_BERKELEY_DB */ | |
| 571 | |
| 572 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /* | |
| 573 Return the last error associated with DATABASE. | |
| 574 */ | |
| 575 (database)) | |
| 576 { | |
| 577 if (NILP (database)) | |
| 578 return lisp_strerror (errno); | |
| 579 | |
| 580 CHECK_DATABASE (database); | |
| 581 | |
| 582 return XDATABASE (database)->funcs->last_error (XDATABASE (database)); | |
| 583 } | |
| 584 | |
| 771 | 585 DEFUN ("open-database", Fopen_database, 1, 6, 0, /* |
| 428 | 586 Return a new database object opened on FILE. |
| 587 Optional arguments TYPE and SUBTYPE specify the database type. | |
| 588 Optional argument ACCESS specifies the access rights, which may be any | |
| 589 combination of 'r' 'w' and '+', for read, write, and creation flags. | |
| 590 Optional argument MODE gives the permissions to use when opening FILE, | |
| 591 and defaults to 0755. | |
| 771 | 592 Optional argument CODESYS specifies the coding system used to encode/decode |
| 593 data passed to/from the database, and defaults to the value of the | |
| 594 variable `database-coding-system'. | |
| 428 | 595 */ |
| 771 | 596 (file, type, subtype, access_, mode, codesys)) |
| 428 | 597 { |
| 598 /* This function can GC */ | |
| 599 int modemask; | |
| 600 int accessmask = 0; | |
| 601 Lisp_Database *db = NULL; | |
| 602 char *filename; | |
| 603 struct gcpro gcpro1, gcpro2; | |
| 604 | |
| 605 CHECK_STRING (file); | |
| 606 GCPRO2 (file, access_); | |
| 607 file = Fexpand_file_name (file, Qnil); | |
| 608 UNGCPRO; | |
| 609 | |
| 440 | 610 TO_EXTERNAL_FORMAT (LISP_STRING, file, |
| 611 C_STRING_ALLOCA, filename, | |
| 612 Qfile_name); | |
| 428 | 613 |
| 614 if (NILP (access_)) | |
| 615 { | |
| 616 accessmask = O_RDWR | O_CREAT; | |
| 617 } | |
| 618 else | |
| 619 { | |
| 620 char *acc; | |
| 621 CHECK_STRING (access_); | |
| 622 acc = (char *) XSTRING_DATA (access_); | |
| 623 | |
| 624 if (strchr (acc, '+')) | |
| 625 accessmask |= O_CREAT; | |
| 626 | |
| 627 { | |
| 628 char *rp = strchr (acc, 'r'); | |
| 629 char *wp = strchr (acc, 'w'); | |
| 630 if (rp && wp) accessmask |= O_RDWR; | |
| 631 else if (wp) accessmask |= O_WRONLY; | |
| 632 else accessmask |= O_RDONLY; | |
| 633 } | |
| 634 } | |
| 635 | |
| 636 if (NILP (mode)) | |
| 637 { | |
| 638 modemask = 0755; /* rwxr-xr-x */ | |
| 639 } | |
| 640 else | |
| 641 { | |
| 642 CHECK_INT (mode); | |
| 643 modemask = XINT (mode); | |
| 644 } | |
| 645 | |
| 771 | 646 if (NILP (codesys)) |
| 647 codesys = Vdatabase_coding_system; | |
| 648 | |
| 649 codesys = get_coding_system_for_text_file (Vdatabase_coding_system, 1); | |
| 650 | |
| 428 | 651 #ifdef HAVE_DBM |
| 652 if (NILP (type) || EQ (type, Qdbm)) | |
| 653 { | |
| 654 DBM *dbase = dbm_open (filename, accessmask, modemask); | |
| 655 if (!dbase) | |
| 656 return Qnil; | |
| 657 | |
| 658 db = allocate_database (); | |
| 659 db->dbm_handle = dbase; | |
| 660 db->funcs = &ndbm_func_block; | |
| 771 | 661 db->coding_system = codesys; |
| 428 | 662 goto db_done; |
| 663 } | |
| 664 #endif /* HAVE_DBM */ | |
| 665 | |
| 666 #ifdef HAVE_BERKELEY_DB | |
| 667 if (NILP (type) || EQ (type, Qberkeley_db)) | |
| 668 { | |
| 669 DBTYPE real_subtype; | |
| 670 DB *dbase; | |
| 671 #if DB_VERSION_MAJOR != 1 | |
| 672 int status; | |
| 673 #endif | |
| 674 | |
| 675 if (EQ (subtype, Qhash) || NILP (subtype)) | |
| 676 real_subtype = DB_HASH; | |
| 677 else if (EQ (subtype, Qbtree)) | |
| 678 real_subtype = DB_BTREE; | |
| 679 else if (EQ (subtype, Qrecno)) | |
| 680 real_subtype = DB_RECNO; | |
| 448 | 681 #if DB_VERSION_MAJOR > 2 |
| 682 else if (EQ (subtype, Qqueue)) | |
| 683 real_subtype = DB_QUEUE; | |
| 684 #endif | |
| 428 | 685 else |
| 563 | 686 invalid_constant ("Unsupported subtype", subtype); |
| 428 | 687 |
| 688 #if DB_VERSION_MAJOR == 1 | |
| 689 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL); | |
| 690 if (!dbase) | |
| 691 return Qnil; | |
| 692 #else | |
| 693 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY, | |
| 694 other flags shouldn't be set */ | |
| 695 if (NILP (access_)) | |
| 696 accessmask = DB_CREATE; | |
| 697 else | |
| 698 { | |
| 699 char *acc; | |
| 700 CHECK_STRING (access_); | |
| 701 acc = (char *) XSTRING_DATA (access_); | |
| 702 accessmask = 0; | |
| 703 | |
| 704 if (strchr (acc, '+')) | |
| 705 accessmask |= DB_CREATE; | |
| 706 | |
| 707 if (strchr (acc, 'r') && !strchr (acc, 'w')) | |
| 708 accessmask |= DB_RDONLY; | |
| 709 } | |
| 448 | 710 #if DB_VERSION_MAJOR == 2 |
| 428 | 711 status = db_open (filename, real_subtype, accessmask, |
| 712 modemask, NULL , NULL, &dbase); | |
| 713 if (status) | |
| 714 return Qnil; | |
| 448 | 715 #else |
| 716 status = db_create (&dbase, NULL, 0); | |
| 717 if (status) | |
| 718 return Qnil; | |
| 1141 | 719 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1) |
| 448 | 720 status = dbase->open (dbase, filename, NULL, |
| 721 real_subtype, accessmask, modemask); | |
| 1141 | 722 #else /* DB_VERSION >= 4.1 */ |
| 1377 | 723 /* You can't use DB_AUTO_COMMIT unless you have a txn environment. */ |
| 1141 | 724 status = dbase->open (dbase, NULL, filename, NULL, real_subtype, |
| 1377 | 725 accessmask, modemask); |
| 1141 | 726 #endif /* DB_VERSION < 4.1 */ |
| 448 | 727 if (status) |
| 728 { | |
| 729 dbase->close (dbase, 0); | |
| 730 return Qnil; | |
| 731 } | |
| 732 #endif /* DB_VERSION_MAJOR > 2 */ | |
| 733 /* Normalize into system specific file modes. Only for printing */ | |
| 734 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR; | |
| 428 | 735 #endif /* DB_VERSION_MAJOR */ |
| 736 | |
| 737 db = allocate_database (); | |
| 738 db->db_handle = dbase; | |
| 739 db->funcs = &berk_func_block; | |
| 771 | 740 db->coding_system = codesys; |
| 428 | 741 goto db_done; |
| 742 } | |
| 743 #endif /* HAVE_BERKELEY_DB */ | |
| 744 | |
| 563 | 745 invalid_constant ("Unsupported database type", type); |
| 428 | 746 return Qnil; |
| 747 | |
| 748 db_done: | |
| 749 db->live_p = 1; | |
| 750 db->fname = file; | |
| 751 db->mode = modemask; | |
| 752 db->access_ = accessmask; | |
| 753 | |
| 793 | 754 return wrap_database (db); |
| 428 | 755 } |
| 756 | |
| 757 DEFUN ("put-database", Fput_database, 3, 4, 0, /* | |
| 758 Store KEY and VALUE in DATABASE. | |
| 759 If optional fourth arg REPLACE is non-nil, | |
| 760 replace any existing entry in the database. | |
| 761 */ | |
| 762 (key, value, database, replace)) | |
| 763 { | |
| 764 CHECK_LIVE_DATABASE (database); | |
| 765 CHECK_STRING (key); | |
| 766 CHECK_STRING (value); | |
| 767 { | |
| 768 Lisp_Database *db = XDATABASE (database); | |
| 769 int status = db->funcs->put (db, key, value, replace); | |
| 770 return status ? Qt : Qnil; | |
| 771 } | |
| 772 } | |
| 773 | |
| 774 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /* | |
| 775 Remove KEY from DATABASE. | |
| 776 */ | |
| 777 (key, database)) | |
| 778 { | |
| 779 CHECK_LIVE_DATABASE (database); | |
| 780 CHECK_STRING (key); | |
| 781 { | |
| 782 Lisp_Database *db = XDATABASE (database); | |
| 783 int status = db->funcs->rem (db, key); | |
| 784 return status ? Qt : Qnil; | |
| 785 } | |
| 786 } | |
| 787 | |
| 788 DEFUN ("get-database", Fget_database, 2, 3, 0, /* | |
| 789 Return value for KEY in DATABASE. | |
| 790 If there is no corresponding value, return DEFAULT (defaults to nil). | |
| 791 */ | |
| 792 (key, database, default_)) | |
| 793 { | |
| 794 CHECK_LIVE_DATABASE (database); | |
| 795 CHECK_STRING (key); | |
| 796 { | |
| 797 Lisp_Database *db = XDATABASE (database); | |
| 798 Lisp_Object retval = db->funcs->get (db, key); | |
| 799 return NILP (retval) ? default_ : retval; | |
| 800 } | |
| 801 } | |
| 802 | |
| 803 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /* | |
| 804 Map FUNCTION over entries in DATABASE, calling it with two args, | |
| 805 each key and value in the database. | |
| 806 */ | |
| 807 (function, database)) | |
| 808 { | |
| 809 CHECK_LIVE_DATABASE (database); | |
| 810 | |
| 811 XDATABASE (database)->funcs->map (XDATABASE (database), function); | |
| 812 | |
| 813 return Qnil; | |
| 814 } | |
| 815 | |
| 816 void | |
| 817 syms_of_database (void) | |
| 818 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
819 INIT_LISP_OBJECT (database); |
| 442 | 820 |
| 563 | 821 DEFSYMBOL (Qdatabasep); |
| 428 | 822 #ifdef HAVE_DBM |
| 563 | 823 DEFSYMBOL (Qdbm); |
| 428 | 824 #endif |
| 825 #ifdef HAVE_BERKELEY_DB | |
| 563 | 826 DEFSYMBOL (Qberkeley_db); |
| 827 DEFSYMBOL (Qhash); | |
| 828 DEFSYMBOL (Qbtree); | |
| 829 DEFSYMBOL (Qrecno); | |
| 448 | 830 #if DB_VERSION_MAJOR > 2 |
| 563 | 831 DEFSYMBOL (Qqueue); |
| 448 | 832 #endif |
| 563 | 833 DEFSYMBOL (Qunknown); |
| 428 | 834 #endif |
| 835 | |
| 836 DEFSUBR (Fopen_database); | |
| 837 DEFSUBR (Fdatabasep); | |
| 838 DEFSUBR (Fmapdatabase); | |
| 839 DEFSUBR (Fput_database); | |
| 840 DEFSUBR (Fget_database); | |
| 841 DEFSUBR (Fremove_database); | |
| 842 DEFSUBR (Fdatabase_type); | |
| 843 DEFSUBR (Fdatabase_subtype); | |
| 844 DEFSUBR (Fdatabase_last_error); | |
| 845 DEFSUBR (Fdatabase_live_p); | |
| 846 DEFSUBR (Fdatabase_file_name); | |
| 847 DEFSUBR (Fclose_database); | |
| 848 } | |
| 849 | |
| 850 void | |
| 851 vars_of_database (void) | |
| 852 { | |
| 853 #ifdef HAVE_DBM | |
| 854 Fprovide (Qdbm); | |
| 855 #endif | |
| 856 #ifdef HAVE_BERKELEY_DB | |
| 857 Fprovide (Qberkeley_db); | |
| 858 #endif | |
| 859 | |
| 860 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* | |
| 771 | 861 Default coding system used to convert data in database files. |
| 428 | 862 */ ); |
| 771 | 863 Vdatabase_coding_system = Qnative; |
| 428 | 864 } |