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         Lisp_Database *db = XDATABASE(obj);
 166         Lisp_Object tmp1, tmp2;
 167
 168         if (print_readably) {
 169                 error("printing unreadable object #<database 0x%x>",
 170                       db->header.uid);
 171         }
 172         write_c_string("#<database \"", printcharfun);
 173         print_internal(db->fname, printcharfun, 0);
 174
 175         tmp1 = db->funcs->get_type(db);
 176         tmp2 = db->funcs->get_subtype(db);
 177         write_fmt_string(printcharfun,
 178                          "\" (%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 }
 186
 187 static void finalize_database(void *header, int for_disksave)
 188 {
 189         Lisp_Database *db = (Lisp_Database *) header;
 190
 191         if (for_disksave) {
 192                 Lisp_Object object;
 193                 XSETDATABASE(object, db);
 194
 195                 signal_simple_error
 196                     ("Can't dump an emacs containing database objects", object);
 197         }
 198         db->funcs->close(db);
 199 }
 200
 201 DEFINE_LRECORD_IMPLEMENTATION("database", database,
 202                               mark_database, print_database,
 203                               finalize_database, 0, 0, 0, Lisp_Database);
 204
 205 DEFUN("close-database", Fclose_database, 1, 1, 0,       /*
 206 Close database DATABASE.
 207 */
 208       (database))
 209 {
 210         Lisp_Database *db;
 211         CHECK_LIVE_DATABASE(database);
 212         db = XDATABASE(database);
 213         db->funcs->close(db);
 214         db->live_p = 0;
 215         return Qnil;
 216 }
 217
 218 DEFUN("database-type", Fdatabase_type, 1, 1, 0, /*
 219 Return the type of database DATABASE.
 220 */
 221       (database))
 222 {
 223         CHECK_DATABASE(database);
 224
 225         return XDATABASE(database)->funcs->get_type(XDATABASE(database));
 226 }
 227
 228 DEFUN("database-subtype", Fdatabase_subtype, 1, 1, 0,   /*
 229 Return the subtype of database DATABASE, if any.
 230 */
 231       (database))
 232 {
 233         CHECK_DATABASE(database);
 234
 235         return XDATABASE(database)->funcs->get_subtype(XDATABASE(database));
 236 }
 237
 238 DEFUN("database-live-p", Fdatabase_live_p, 1, 1, 0,     /*
 239 Return t if OBJECT is an active database.
 240 */
 241       (object))
 242 {
 243         return DATABASEP(object) && DATABASE_LIVE_P(XDATABASE(object)) ?
 244             Qt : Qnil;
 245 }
 246
 247 DEFUN("database-file-name", Fdatabase_file_name, 1, 1, 0,       /*
 248 Return the filename associated with the database DATABASE.
 249 */
 250       (database))
 251 {
 252         CHECK_DATABASE(database);
 253
 254         return XDATABASE(database)->fname;
 255 }
 256
 257 DEFUN("databasep", Fdatabasep, 1, 1, 0, /*
 258 Return t if OBJECT is a database.
 259 */
 260       (object))
 261 {
 262         return DATABASEP(object) ? Qt : Qnil;
 263 }
 264
 265 #ifdef HAVE_DBM
 266 static void 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; keydatum = dbm_nextkey(db->dbm_handle)) {
 273                 valdatum = dbm_fetch(db->dbm_handle, keydatum);
 274                 key =
 275                     make_string((unsigned char *)keydatum.dptr, keydatum.dsize);
 276                 val =
 277                     make_string((unsigned char *)valdatum.dptr, valdatum.dsize);
 278                 call2(func, key, val);
 279         }
 280 }
 281
 282 static Lisp_Object dbm_get(Lisp_Database * db, Lisp_Object key)
 283 {
 284         datum keydatum, valdatum;
 285
 286         keydatum.dptr = (char *)XSTRING_DATA(key);
 287         keydatum.dsize = XSTRING_LENGTH(key);
 288         valdatum = dbm_fetch(db->dbm_handle, keydatum);
 289
 290         return (valdatum.dptr
 291                 ? make_string((unsigned char *)valdatum.dptr, valdatum.dsize)
 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
 301         valdatum.dptr = (char *)XSTRING_DATA(val);
 302         valdatum.dsize = XSTRING_LENGTH(val);
 303         keydatum.dptr = (char *)XSTRING_DATA(key);
 304         keydatum.dsize = XSTRING_LENGTH(key);
 305
 306         return !dbm_store(db->dbm_handle, keydatum, valdatum,
 307                           NILP(replace) ? DBM_INSERT : DBM_REPLACE);
 308 }
 309
 310 static int dbm_remove(Lisp_Database * db, Lisp_Object key)
 311 {
 312         datum keydatum;
 313
 314         keydatum.dptr = (char *)XSTRING_DATA(key);
 315         keydatum.dsize = XSTRING_LENGTH(key);
 316
 317         return dbm_delete(db->dbm_handle, keydatum);
 318 }
 319
 320 static Lisp_Object dbm_type(Lisp_Database * db)
 321 {
 322         return Qdbm;
 323 }
 324
 325 static Lisp_Object dbm_subtype(Lisp_Database * db)
 326 {
 327         return Qnil;
 328 }
 329
 330 static Lisp_Object dbm_lasterr(Lisp_Database * db)
 331 {
 332         return lisp_strerror(db->dberrno);
 333 }
 334
 335 static void dbm_closeit(Lisp_Database * db)
 336 {
 337         if (db->dbm_handle) {
 338                 dbm_close(db->dbm_handle);
 339                 db->dbm_handle = NULL;
 340         }
 341 }
 342
 343 static DB_FUNCS ndbm_func_block = {
 344         dbm_subtype,
 345         dbm_type,
 346         dbm_get,
 347         dbm_put,
 348         dbm_remove,
 349         dbm_map,
 350         dbm_closeit,
 351         dbm_lasterr
 352 };
 353 #endif                          /* HAVE_DBM */
 354
 355 #ifdef HAVE_BERKELEY_DB
 356 static Lisp_Object berkdb_type(Lisp_Database * db)
 357 {
 358         return Qberkeley_db;
 359 }
 360
 361 static Lisp_Object berkdb_subtype(Lisp_Database * db)
 362 {
 363         if (!db->db_handle)
 364                 return Qnil;
 365
 366         switch (db->db_handle->type) {
 367         case DB_BTREE:
 368                 return Qbtree;
 369         case DB_HASH:
 370                 return Qhash;
 371         case DB_RECNO:
 372                 return Qrecno;
 373 #if DB_VERSION_MAJOR > 2
 374         case DB_QUEUE:
 375                 return Qqueue;
 376 #endif
 377 #ifdef HAVE_DB_UNKNOWN
 378         case DB_UNKNOWN:
 379 #endif
 380         default:
 381                 return Qunknown;
 382         }
 383 }
 384
 385 static Lisp_Object berkdb_lasterr(Lisp_Database * db)
 386 {
 387         return lisp_strerror(db->dberrno);
 388 }
 389
 390 static Lisp_Object berkdb_get(Lisp_Database * db, Lisp_Object key)
 391 {
 392         DBT keydatum, valdatum;
 393         int status = 0;
 394
 395         /* DB Version 2 requires DBT's to be zeroed before use. */
 396         xzero(keydatum);
 397         xzero(valdatum);
 398
 399         keydatum.data = XSTRING_DATA(key);
 400         keydatum.size = XSTRING_LENGTH(key);
 401
 402 #if DB_VERSION_MAJOR == 1
 403         status = db->db_handle->get(db->db_handle, &keydatum, &valdatum, 0);
 404 #else
 405         status =
 406             db->db_handle->get(db->db_handle, NULL, &keydatum, &valdatum, 0);
 407 #endif                          /* DB_VERSION_MAJOR */
 408
 409         if (!status)
 410                 /* #### Not mule-ized! will crash! */
 411                 return make_string((Bufbyte *) valdatum.data, valdatum.size);
 412
 413 #if DB_VERSION_MAJOR == 1
 414         db->dberrno = (status == 1) ? -1 : errno;
 415 #else
 416         db->dberrno = (status < 0) ? -1 : errno;
 417 #endif                          /* DB_VERSION_MAJOR */
 418
 419         return Qnil;
 420 }
 421
 422 static int
 423 berkdb_put(Lisp_Database * db,
 424            Lisp_Object key, Lisp_Object val, Lisp_Object replace)
 425 {
 426         DBT keydatum, valdatum;
 427         int status = 0;
 428
 429         /* DB Version 2 requires DBT's to be zeroed before use. */
 430         xzero(keydatum);
 431         xzero(valdatum);
 432
 433         keydatum.data = XSTRING_DATA(key);
 434         keydatum.size = XSTRING_LENGTH(key);
 435         valdatum.data = XSTRING_DATA(val);
 436         valdatum.size = XSTRING_LENGTH(val);
 437 #if DB_VERSION_MAJOR == 1
 438         status = db->db_handle->put(db->db_handle, &keydatum, &valdatum,
 439                                     NILP(replace) ? R_NOOVERWRITE : 0);
 440         db->dberrno = (status == 1) ? -1 : errno;
 441 #else
 442         status = db->db_handle->put(db->db_handle, NULL, &keydatum, &valdatum,
 443                                     NILP(replace) ? DB_NOOVERWRITE : 0);
 444         db->dberrno = (status < 0) ? -1 : errno;
 445 #endif                          /* DV_VERSION_MAJOR = 2 */
 446
 447         return status;
 448 }
 449
 450 static int berkdb_remove(Lisp_Database * db, Lisp_Object key)
 451 {
 452         DBT keydatum;
 453         int status;
 454
 455         /* DB Version 2 requires DBT's to be zeroed before use. */
 456         xzero(keydatum);
 457
 458         keydatum.data = XSTRING_DATA(key);
 459         keydatum.size = XSTRING_LENGTH(key);
 460
 461 #if DB_VERSION_MAJOR == 1
 462         status = db->db_handle->del(db->db_handle, &keydatum, 0);
 463 #else
 464         status = db->db_handle->del(db->db_handle, NULL, &keydatum, 0);
 465 #endif                          /* DB_VERSION_MAJOR */
 466
 467         if (!status)
 468                 return 0;
 469
 470 #if DB_VERSION_MAJOR == 1
 471         db->dberrno = (status == 1) ? -1 : errno;
 472 #else
 473         db->dberrno = (status < 0) ? -1 : errno;
 474 #endif                          /* DB_VERSION_MAJOR */
 475
 476         return 1;
 477 }
 478
 479 static void berkdb_map(Lisp_Database * db, Lisp_Object func)
 480 {
 481         DBT keydatum, valdatum;
 482         Lisp_Object key, val;
 483         DB *dbp = db->db_handle;
 484         int status;
 485
 486         xzero(keydatum);
 487         xzero(valdatum);
 488
 489 #if DB_VERSION_MAJOR == 1
 490         for (status = dbp->seq(dbp, &keydatum, &valdatum, R_FIRST);
 491              status == 0;
 492              status = dbp->seq(dbp, &keydatum, &valdatum, R_NEXT)) {
 493                 /* #### Needs mule-izing */
 494                 key = make_string((Bufbyte *) keydatum.data, keydatum.size);
 495                 val = make_string((Bufbyte *) valdatum.data, valdatum.size);
 496                 call2(func, key, val);
 497         }
 498 #else
 499         {
 500                 DBC *dbcp;
 501
 502 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
 503                 status = dbp->cursor(dbp, NULL, &dbcp, 0);
 504 #else
 505                 status = dbp->cursor(dbp, NULL, &dbcp);
 506 #endif
 507                 for (status = dbcp->c_get(dbcp, &keydatum, &valdatum, DB_FIRST);
 508                      status == 0;
 509                      status = dbcp->c_get(dbcp, &keydatum, &valdatum, DB_NEXT))
 510                 {
 511                         /* #### Needs mule-izing */
 512                         key =
 513                             make_string((Bufbyte *) keydatum.data,
 514                                         keydatum.size);
 515                         val =
 516                             make_string((Bufbyte *) valdatum.data,
 517                                         valdatum.size);
 518                         call2(func, key, val);
 519                 }
 520                 dbcp->c_close(dbcp);
 521         }
 522 #endif                          /* DB_VERSION_MAJOR */
 523 }
 524
 525 static void berkdb_close(Lisp_Database * db)
 526 {
 527         if (db->db_handle) {
 528 #if DB_VERSION_MAJOR == 1
 529                 db->db_handle->sync(db->db_handle, 0);
 530                 db->db_handle->close(db->db_handle);
 531 #else
 532                 db->db_handle->sync(db->db_handle, 0);
 533                 db->db_handle->close(db->db_handle, 0);
 534 #endif                          /* DB_VERSION_MAJOR */
 535                 db->db_handle = NULL;
 536         }
 537 }
 538
 539 static DB_FUNCS berk_func_block = {
 540         berkdb_subtype,
 541         berkdb_type,
 542         berkdb_get,
 543         berkdb_put,
 544         berkdb_remove,
 545         berkdb_map,
 546         berkdb_close,
 547         berkdb_lasterr
 548 };
 549 #endif                          /* HAVE_BERKELEY_DB */
 550
 551 DEFUN("database-last-error", Fdatabase_last_error, 0, 1, 0,     /*
 552 Return the last error associated with DATABASE.
 553 */
 554       (database))
 555 {
 556         if (NILP(database))
 557                 return lisp_strerror(errno);
 558
 559         CHECK_DATABASE(database);
 560
 561         return XDATABASE(database)->funcs->last_error(XDATABASE(database));
 562 }
 563
 564 DEFUN("open-database", Fopen_database, 1, 5, 0, /*
 565 Return a new database object opened on FILE.
 566 Optional arguments TYPE and SUBTYPE specify the database type.
 567 Optional argument ACCESS specifies the access rights, which may be any
 568 combination of 'r' 'w' and '+', for read, write, and creation flags.
 569 Optional argument MODE gives the permissions to use when opening FILE,
 570 and defaults to 0755.
 571 */
 572       (file, type, subtype, access_, mode))
 573 {
 574         /* This function can GC */
 575         int modemask;
 576         int accessmask = 0;
 577         Lisp_Database *db = NULL;
 578         char *filename;
 579         struct gcpro gcpro1, gcpro2;
 580
 581         CHECK_STRING(file);
 582         GCPRO2(file, access_);
 583         file = Fexpand_file_name(file, Qnil);
 584         UNGCPRO;
 585
 586         TO_EXTERNAL_FORMAT(LISP_STRING, file,
 587                            C_STRING_ALLOCA, filename, Qfile_name);
 588
 589         if (NILP(access_)) {
 590                 accessmask = O_RDWR | O_CREAT;
 591         } else {
 592                 char *acc;
 593                 CHECK_STRING(access_);
 594                 acc = (char *)XSTRING_DATA(access_);
 595
 596                 if (strchr(acc, '+'))
 597                         accessmask |= O_CREAT;
 598
 599                 {
 600                         char *rp = strchr(acc, 'r');
 601                         char *wp = strchr(acc, 'w');
 602                         if (rp && wp)
 603                                 accessmask |= O_RDWR;
 604                         else if (wp)
 605                                 accessmask |= O_WRONLY;
 606                         else
 607                                 accessmask |= O_RDONLY;
 608                 }
 609         }
 610
 611         if (NILP(mode)) {
 612                 modemask = 0755;        /* rwxr-xr-x */
 613         } else {
 614                 CHECK_INT(mode);
 615                 modemask = XINT(mode);
 616         }
 617
 618 #ifdef HAVE_DBM
 619         if (NILP(type) || EQ(type, Qdbm)) {
 620                 DBM *dbase = dbm_open(filename, accessmask, modemask);
 621                 if (!dbase)
 622                         return Qnil;
 623
 624                 db = allocate_database();
 625                 db->dbm_handle = dbase;
 626                 db->funcs = &ndbm_func_block;
 627                 goto db_done;
 628         }
 629 #endif                          /* HAVE_DBM */
 630
 631 #ifdef HAVE_BERKELEY_DB
 632         if (NILP(type) || EQ(type, Qberkeley_db)) {
 633                 DBTYPE real_subtype;
 634                 DB *dbase;
 635 #if DB_VERSION_MAJOR != 1
 636                 int status;
 637 #endif
 638
 639                 if (EQ(subtype, Qhash) || NILP(subtype))
 640                         real_subtype = DB_HASH;
 641                 else if (EQ(subtype, Qbtree))
 642                         real_subtype = DB_BTREE;
 643                 else if (EQ(subtype, Qrecno))
 644                         real_subtype = DB_RECNO;
 645 #if DB_VERSION_MAJOR > 2
 646                 else if (EQ(subtype, Qqueue))
 647                         real_subtype = DB_QUEUE;
 648 #endif
 649                 else
 650                         signal_simple_error("Unsupported subtype", subtype);
 651
 652 #if DB_VERSION_MAJOR == 1
 653                 dbase =
 654                     dbopen(filename, accessmask, modemask, real_subtype, NULL);
 655                 if (!dbase)
 656                         return Qnil;
 657 #else
 658                 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 659                    other flags shouldn't be set */
 660                 if (NILP(access_))
 661                         accessmask = DB_CREATE;
 662                 else {
 663                         char *acc;
 664                         CHECK_STRING(access_);
 665                         acc = (char *)XSTRING_DATA(access_);
 666                         accessmask = 0;
 667
 668                         if (strchr(acc, '+'))
 669                                 accessmask |= DB_CREATE;
 670
 671                         if (strchr(acc, 'r') && !strchr(acc, 'w'))
 672                                 accessmask |= DB_RDONLY;
 673                 }
 674 #if DB_VERSION_MAJOR == 2
 675                 status = db_open(filename, real_subtype, accessmask,
 676                                  modemask, NULL, NULL, &dbase);
 677                 if (status)
 678                         return Qnil;
 679 #else
 680                 status = db_create(&dbase, NULL, 0);
 681                 if (status)
 682                         return Qnil;
 683 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1)
 684                 status = dbase->open(dbase, filename, NULL,
 685                                      real_subtype, accessmask, modemask);
 686 #else                           /* DB_VERSION >= 4.1 */
 687                 /* DB_AUTO_COMMIT requires transaction support, don't try it */
 688                 status = dbase->open(dbase, NULL, filename, NULL, real_subtype,
 689                                      accessmask, modemask);
 690 #endif                          /* DB_VERSION < 4.1 */
 691                 if (status) {
 692                         dbase->close(dbase, 0);
 693                         return Qnil;
 694                 }
 695 #endif                          /* DB_VERSION_MAJOR > 2 */
 696                 /* Normalize into system specific file modes. Only for printing */
 697                 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
 698 #endif                          /* DB_VERSION_MAJOR */
 699
 700                 db = allocate_database();
 701                 db->db_handle = dbase;
 702                 db->funcs = &berk_func_block;
 703                 goto db_done;
 704         }
 705 #endif                          /* HAVE_BERKELEY_DB */
 706
 707         signal_simple_error("Unsupported database type", type);
 708         return Qnil;
 709
 710       db_done:
 711         db->live_p = 1;
 712         db->fname = file;
 713         db->mode = modemask;
 714         db->access_ = accessmask;
 715
 716         {
 717                 Lisp_Object retval;
 718                 XSETDATABASE(retval, db);
 719                 return retval;
 720         }
 721 }
 722
 723 DEFUN("put-database", Fput_database, 3, 4, 0,   /*
 724 Store KEY and VALUE in DATABASE.
 725 If optional fourth arg REPLACE is non-nil,
 726 replace any existing entry in the database.
 727 */
 728       (key, value, database, replace))
 729 {
 730         CHECK_LIVE_DATABASE(database);
 731         CHECK_STRING(key);
 732         CHECK_STRING(value);
 733         {
 734                 Lisp_Database *db = XDATABASE(database);
 735                 int status = db->funcs->put(db, key, value, replace);
 736                 return status ? Qt : Qnil;
 737         }
 738 }
 739
 740 DEFUN("remove-database", Fremove_database, 2, 2, 0,     /*
 741 Remove KEY from DATABASE.
 742 */
 743       (key, database))
 744 {
 745         CHECK_LIVE_DATABASE(database);
 746         CHECK_STRING(key);
 747         {
 748                 Lisp_Database *db = XDATABASE(database);
 749                 int status = db->funcs->rem(db, key);
 750                 return status ? Qt : Qnil;
 751         }
 752 }
 753
 754 DEFUN("get-database", Fget_database, 2, 3, 0,   /*
 755 Return value for KEY in DATABASE.
 756 If there is no corresponding value, return DEFAULT (defaults to nil).
 757 */
 758       (key, database, default_))
 759 {
 760         CHECK_LIVE_DATABASE(database);
 761         CHECK_STRING(key);
 762         {
 763                 Lisp_Database *db = XDATABASE(database);
 764                 Lisp_Object retval = db->funcs->get(db, key);
 765                 return NILP(retval) ? default_ : retval;
 766         }
 767 }
 768
 769 DEFUN("map-database", Fmapdatabase, 2, 2, 0,    /*
 770 Map FUNCTION over entries in DATABASE, calling it with two args,
 771 each key and value in the database.
 772 */
 773       (function, database))
 774 {
 775         CHECK_LIVE_DATABASE(database);
 776
 777         XDATABASE(database)->funcs->map(XDATABASE(database), function);
 778
 779         return Qnil;
 780 }
 781
 782 void syms_of_database(void)
 783 {
 784         INIT_LRECORD_IMPLEMENTATION(database);
 785
 786         defsymbol(&Qdatabasep, "databasep");
 787 #ifdef HAVE_DBM
 788         defsymbol(&Qdbm, "dbm");
 789 #endif
 790 #ifdef HAVE_BERKELEY_DB
 791         defsymbol(&Qberkeley_db, "berkeley-db");
 792         defsymbol(&Qhash, "hash");
 793         defsymbol(&Qbtree, "btree");
 794         defsymbol(&Qrecno, "recno");
 795 #if DB_VERSION_MAJOR > 2
 796         defsymbol(&Qqueue, "queue");
 797 #endif
 798         defsymbol(&Qunknown, "unknown");
 799 #endif
 800
 801         DEFSUBR(Fopen_database);
 802         DEFSUBR(Fdatabasep);
 803         DEFSUBR(Fmapdatabase);
 804         DEFSUBR(Fput_database);
 805         DEFSUBR(Fget_database);
 806         DEFSUBR(Fremove_database);
 807         DEFSUBR(Fdatabase_type);
 808         DEFSUBR(Fdatabase_subtype);
 809         DEFSUBR(Fdatabase_last_error);
 810         DEFSUBR(Fdatabase_live_p);
 811         DEFSUBR(Fdatabase_file_name);
 812         DEFSUBR(Fclose_database);
 813 }
 814
 815 void vars_of_database(void)
 816 {
 817 #ifdef HAVE_DBM
 818         Fprovide(Qdbm);
 819 #endif
 820 #ifdef HAVE_BERKELEY_DB
 821         Fprovide(Qberkeley_db);
 822 #endif
 823
 824 #if 0                           /* #### implement me! */
 825 #ifdef MULE
 826         DEFVAR_LISP("database-coding-system", &Vdatabase_coding_system  /*
 827 Coding system used to convert data in database files.
 828                                                                          */ );
 829         Vdatabase_coding_system = Qnil;
 830 #endif
 831 #endif                          /* 0 */
 832 }