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