cgit.sxemacs.org Git - sxemacs/blob - src/database/database.c

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