git.chise.org Git - chise/xemacs-chise.git.1/blob - src/database.c

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