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 "buffer.h"
  31 #include <errno.h>
  32
  33 #ifndef HAVE_DATABASE
  34 #error HAVE_DATABASE not defined!!
  35 #endif
  36
  37 #include "database.h"         /* Our include file */
  38
  39 #ifdef HAVE_BERKELEY_DB
  40 /* Work around Berkeley DB's use of int types which are defined
  41    slightly differently in the not quite yet standard <inttypes.h>.
  42    See db.h for details of why we're resorting to this... */
  43 /* glibc 2.1 doesn't have this problem with DB 2.x */
  44 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1)
  45 #ifdef HAVE_INTTYPES_H
  46 #define __BIT_TYPES_DEFINED__
  47 #include <inttypes.h>
  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 /* WE_DONT_NEED_QUADS */
  54 #endif /* HAVE_INTTYPES_H */
  55 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */
  56 #include DB_H_PATH              /* Berkeley db's header file */
  57 #ifndef DB_VERSION_MAJOR
  58 # define DB_VERSION_MAJOR 1
  59 #endif /* DB_VERSION_MAJOR */
  60 Lisp_Object Qberkeley_db;
  61 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
  62 #endif /* HAVE_BERKELEY_DB */
  63
  64 #ifdef HAVE_DBM
  65 #include <ndbm.h>
  66 Lisp_Object Qdbm;
  67 #endif /* HAVE_DBM */
  68
  69 #ifdef MULE
  70 /* #### The following should be settable on a per-database level.
  71    But the whole coding-system infrastructure should be rewritten someday.
  72    We really need coding-system aliases. -- martin */
  73 Lisp_Object Vdatabase_coding_system;
  74 #endif
  75
  76 Lisp_Object Qdatabasep;
  77
  78 struct Lisp_Database;
  79 typedef struct Lisp_Database Lisp_Database;
  80
  81 typedef struct
  82 {
  83   Lisp_Object (*get_subtype) (Lisp_Database *);
  84   Lisp_Object (*get_type) (Lisp_Database *);
  85   Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
  86   int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
  87   int (*rem) (Lisp_Database *, Lisp_Object);
  88   void (*map) (Lisp_Database *, Lisp_Object);
  89   void (*close) (Lisp_Database *);
  90   Lisp_Object (*last_error) (Lisp_Database *);
  91 } DB_FUNCS;
  92
  93 struct Lisp_Database
  94 {
  95   struct lcrecord_header header;
  96   Lisp_Object fname;
  97   int mode;
  98   int access_;
  99   int dberrno;
 100   int live_p;
 101 #ifdef HAVE_DBM
 102   DBM *dbm_handle;
 103 #endif
 104 #ifdef HAVE_BERKELEY_DB
 105   DB *db_handle;
 106 #endif
 107   DB_FUNCS *funcs;
 108 #ifdef MULE
 109   Lisp_Object coding_system;
 110 #endif
 111 };
 112
 113 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
 114 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
 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)))                                 \
 123     signal_simple_error ("Attempting to access closed database", db);   \
 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;
 143 #ifdef MULE
 144   db->coding_system = Fget_coding_system (Qbinary);
 145 #endif
 146   return db;
 147 }
 148
 149 static Lisp_Object
 150 mark_database (Lisp_Object obj)
 151 {
 152   Lisp_Database *db = XDATABASE (obj);
 153   return db->fname;
 154 }
 155
 156 static void
 157 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 158 {
 159   char buf[64];
 160   Lisp_Database *db = XDATABASE (obj);
 161
 162   if (print_readably)
 163     error ("printing unreadable object #<database 0x%x>", db->header.uid);
 164
 165   write_c_string ("#<database \"", printcharfun);
 166   print_internal (db->fname, printcharfun, 0);
 167   sprintf (buf, "\" (%s/%s/%s) 0x%x>",
 168            (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
 169            (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
 170            (!DATABASE_LIVE_P (db)    ? "closed"    :
 171             (db->access_ & O_WRONLY) ? "writeonly" :
 172             (db->access_ & O_RDWR)   ? "readwrite" : "readonly"),
 173            db->header.uid);
 174   write_c_string (buf, printcharfun);
 175 }
 176
 177 static void
 178 finalize_database (void *header, int for_disksave)
 179 {
 180   Lisp_Database *db = (Lisp_Database *) header;
 181
 182   if (for_disksave)
 183     {
 184       Lisp_Object obj;
 185       XSETDATABASE (obj, db);
 186
 187       signal_simple_error
 188         ("Can't dump an emacs containing database objects", obj);
 189     }
 190   db->funcs->close (db);
 191 }
 192
 193 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
 194                                mark_database, print_database,
 195                                finalize_database, 0, 0, 0,
 196                                Lisp_Database);
 197
 198 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
 199 Close database DATABASE.
 200 */
 201        (database))
 202 {
 203   Lisp_Database *db;
 204   CHECK_LIVE_DATABASE (database);
 205   db = XDATABASE (database);
 206   db->funcs->close (db);
 207   db->live_p = 0;
 208   return Qnil;
 209 }
 210
 211 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
 212 Return the type of database DATABASE.
 213 */
 214        (database))
 215 {
 216   CHECK_DATABASE (database);
 217
 218   return XDATABASE (database)->funcs->get_type (XDATABASE (database));
 219 }
 220
 221 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
 222 Return the subtype of database DATABASE, if any.
 223 */
 224        (database))
 225 {
 226   CHECK_DATABASE (database);
 227
 228   return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
 229 }
 230
 231 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
 232 Return t if OBJ is an active database.
 233 */
 234        (obj))
 235 {
 236   return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
 237 }
 238
 239 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
 240 Return the filename associated with the database DATABASE.
 241 */
 242        (database))
 243 {
 244   CHECK_DATABASE (database);
 245
 246   return XDATABASE (database)->fname;
 247 }
 248
 249 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
 250 Return t if OBJ is a database.
 251 */
 252        (obj))
 253 {
 254   return DATABASEP (obj) ? Qt : Qnil;
 255 }
 256
 257 #ifdef HAVE_DBM
 258 static void
 259 dbm_map (Lisp_Database *db, Lisp_Object func)
 260 {
 261   datum keydatum, valdatum;
 262   Lisp_Object key, val;
 263
 264   for (keydatum = dbm_firstkey (db->dbm_handle);
 265        keydatum.dptr != NULL;
 266        keydatum = dbm_nextkey (db->dbm_handle))
 267     {
 268       valdatum = dbm_fetch (db->dbm_handle, keydatum);
 269       key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
 270       val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
 271       call2 (func, key, val);
 272     }
 273 }
 274
 275 static Lisp_Object
 276 dbm_get (Lisp_Database *db, Lisp_Object key)
 277 {
 278   datum keydatum, valdatum;
 279
 280   keydatum.dptr = (char *) XSTRING_DATA (key);
 281   keydatum.dsize = XSTRING_LENGTH (key);
 282   valdatum = dbm_fetch (db->dbm_handle, keydatum);
 283
 284   return (valdatum.dptr
 285           ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
 286           : Qnil);
 287 }
 288
 289 static int
 290 dbm_put (Lisp_Database *db,
 291          Lisp_Object key, Lisp_Object val, Lisp_Object replace)
 292 {
 293   datum keydatum, valdatum;
 294
 295   valdatum.dptr = (char *) XSTRING_DATA (val);
 296   valdatum.dsize = XSTRING_LENGTH (val);
 297   keydatum.dptr = (char *) XSTRING_DATA (key);
 298   keydatum.dsize = XSTRING_LENGTH (key);
 299
 300   return !dbm_store (db->dbm_handle, keydatum, valdatum,
 301                      NILP (replace) ? DBM_INSERT : DBM_REPLACE);
 302 }
 303
 304 static int
 305 dbm_remove (Lisp_Database *db, Lisp_Object key)
 306 {
 307   datum keydatum;
 308
 309   keydatum.dptr = (char *) XSTRING_DATA (key);
 310   keydatum.dsize = XSTRING_LENGTH (key);
 311
 312   return dbm_delete (db->dbm_handle, keydatum);
 313 }
 314
 315 static Lisp_Object
 316 dbm_type (Lisp_Database *db)
 317 {
 318   return Qdbm;
 319 }
 320
 321 static Lisp_Object
 322 dbm_subtype (Lisp_Database *db)
 323 {
 324   return Qnil;
 325 }
 326
 327 static Lisp_Object
 328 dbm_lasterr (Lisp_Database *db)
 329 {
 330   return lisp_strerror (db->dberrno);
 331 }
 332
 333 static void
 334 dbm_closeit (Lisp_Database *db)
 335 {
 336   if (db->dbm_handle)
 337     {
 338       dbm_close (db->dbm_handle);
 339       db->dbm_handle = NULL;
 340     }
 341 }
 342
 343 static DB_FUNCS ndbm_func_block =
 344 {
 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
 358 berkdb_type (Lisp_Database *db)
 359 {
 360   return Qberkeley_db;
 361 }
 362
 363 static Lisp_Object
 364 berkdb_subtype (Lisp_Database *db)
 365 {
 366   if (!db->db_handle)
 367     return Qnil;
 368
 369   switch (db->db_handle->type)
 370     {
 371     case DB_BTREE: return Qbtree;
 372     case DB_HASH:  return Qhash;
 373     case DB_RECNO: return Qrecno;
 374     default:       return Qunknown;
 375     }
 376 }
 377
 378 static Lisp_Object
 379 berkdb_lasterr (Lisp_Database *db)
 380 {
 381   return lisp_strerror (db->dberrno);
 382 }
 383
 384 static Lisp_Object
 385 berkdb_get (Lisp_Database *db, Lisp_Object key)
 386 {
 387   DBT keydatum, valdatum;
 388   int status = 0;
 389
 390   /* DB Version 2 requires DBT's to be zeroed before use. */
 391   xzero (keydatum);
 392   xzero (valdatum);
 393
 394   keydatum.data = XSTRING_DATA (key);
 395   keydatum.size = XSTRING_LENGTH (key);
 396
 397 #if DB_VERSION_MAJOR == 1
 398   status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
 399 #else
 400   status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
 401 #endif /* DB_VERSION_MAJOR */
 402
 403   if (!status)
 404     /* #### Not mule-ized! will crash! */
 405     return make_string ((Bufbyte *) valdatum.data, valdatum.size);
 406
 407 #if DB_VERSION_MAJOR == 1
 408   db->dberrno = (status == 1) ? -1 : errno;
 409 #else
 410   db->dberrno = (status < 0) ? -1 : errno;
 411 #endif /* DB_VERSION_MAJOR */
 412
 413   return Qnil;
 414 }
 415
 416 static int
 417 berkdb_put (Lisp_Database *db,
 418             Lisp_Object key,
 419             Lisp_Object val,
 420             Lisp_Object replace)
 421 {
 422   DBT keydatum, valdatum;
 423   int status = 0;
 424
 425   /* DB Version 2 requires DBT's to be zeroed before use. */
 426   xzero (keydatum);
 427   xzero (valdatum);
 428
 429   keydatum.data = XSTRING_DATA   (key);
 430   keydatum.size = XSTRING_LENGTH (key);
 431   valdatum.data = XSTRING_DATA   (val);
 432   valdatum.size = XSTRING_LENGTH (val);
 433 #if DB_VERSION_MAJOR == 1
 434   status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
 435                                NILP (replace) ? R_NOOVERWRITE : 0);
 436   db->dberrno = (status == 1) ? -1 : errno;
 437 #else
 438   status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
 439                                NILP (replace) ? DB_NOOVERWRITE : 0);
 440   db->dberrno = (status < 0) ? -1 : errno;
 441 #endif/* DV_VERSION_MAJOR = 2 */
 442
 443   return status;
 444 }
 445
 446 static int
 447 berkdb_remove (Lisp_Database *db, Lisp_Object key)
 448 {
 449   DBT keydatum;
 450   int status;
 451
 452   /* DB Version 2 requires DBT's to be zeroed before use. */
 453   xzero (keydatum);
 454
 455   keydatum.data = XSTRING_DATA   (key);
 456   keydatum.size = XSTRING_LENGTH (key);
 457
 458 #if DB_VERSION_MAJOR == 1
 459   status = db->db_handle->del (db->db_handle, &keydatum, 0);
 460 #else
 461   status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
 462 #endif /* DB_VERSION_MAJOR */
 463
 464   if (!status)
 465     return 0;
 466
 467 #if DB_VERSION_MAJOR == 1
 468   db->dberrno = (status == 1) ? -1 : errno;
 469 #else
 470   db->dberrno = (status < 0) ? -1 : errno;
 471 #endif /* DB_VERSION_MAJOR */
 472
 473   return 1;
 474 }
 475
 476 static void
 477 berkdb_map (Lisp_Database *db, Lisp_Object func)
 478 {
 479   DBT keydatum, valdatum;
 480   Lisp_Object key, val;
 481   DB *dbp = db->db_handle;
 482   int status;
 483
 484   xzero (keydatum);
 485   xzero (valdatum);
 486
 487 #if DB_VERSION_MAJOR == 1
 488   for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
 489        status == 0;
 490        status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
 491     {
 492       /* ### Needs mule-izing */
 493       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 494       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 495       call2 (func, key, val);
 496     }
 497 #else
 498   {
 499     DBC *dbcp;
 500
 501 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
 502     status = dbp->cursor (dbp, NULL, &dbcp, 0);
 503 #else
 504     status = dbp->cursor (dbp, NULL, &dbcp);
 505 #endif
 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   }
 517 #endif /* DB_VERSION_MAJOR */
 518 }
 519
 520 static void
 521 berkdb_close (Lisp_Database *db)
 522 {
 523   if (db->db_handle)
 524     {
 525 #if DB_VERSION_MAJOR == 1
 526       db->db_handle->sync  (db->db_handle, 0);
 527       db->db_handle->close (db->db_handle);
 528 #else
 529       db->db_handle->sync  (db->db_handle, 0);
 530       db->db_handle->close (db->db_handle, 0);
 531 #endif /* DB_VERSION_MAJOR */
 532       db->db_handle = NULL;
 533     }
 534 }
 535
 536 static DB_FUNCS berk_func_block =
 537 {
 538   berkdb_subtype,
 539   berkdb_type,
 540   berkdb_get,
 541   berkdb_put,
 542   berkdb_remove,
 543   berkdb_map,
 544   berkdb_close,
 545   berkdb_lasterr
 546 };
 547 #endif /* HAVE_BERKELEY_DB */
 548
 549 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 550 Return the last error associated with DATABASE.
 551 */
 552        (database))
 553 {
 554   if (NILP (database))
 555     return lisp_strerror (errno);
 556
 557   CHECK_DATABASE (database);
 558
 559   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 560 }
 561
 562 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 563 Return a new database object opened on FILE.
 564 Optional arguments TYPE and SUBTYPE specify the database type.
 565 Optional argument ACCESS specifies the access rights, which may be any
 566 combination of 'r' 'w' and '+', for read, write, and creation flags.
 567 Optional argument MODE gives the permissions to use when opening FILE,
 568 and defaults to 0755.
 569 */
 570        (file, type, subtype, access_, mode))
 571 {
 572   /* This function can GC */
 573   int modemask;
 574   int accessmask = 0;
 575   Lisp_Database *db = NULL;
 576   char *filename;
 577   struct gcpro gcpro1, gcpro2;
 578
 579   CHECK_STRING (file);
 580   GCPRO2 (file, access_);
 581   file = Fexpand_file_name (file, Qnil);
 582   UNGCPRO;
 583
 584   GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
 585
 586   if (NILP (access_))
 587     {
 588       accessmask = O_RDWR | O_CREAT;
 589     }
 590   else
 591     {
 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) accessmask |= O_RDWR;
 603         else if (wp)  accessmask |= O_WRONLY;
 604         else          accessmask |= O_RDONLY;
 605       }
 606     }
 607
 608   if (NILP (mode))
 609     {
 610       modemask = 0755;          /* rwxr-xr-x */
 611     }
 612   else
 613     {
 614       CHECK_INT (mode);
 615       modemask = XINT (mode);
 616     }
 617
 618 #ifdef HAVE_DBM
 619   if (NILP (type) || EQ (type, Qdbm))
 620     {
 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     {
 635       DBTYPE real_subtype;
 636       DB *dbase;
 637 #if DB_VERSION_MAJOR != 1
 638       int status;
 639 #endif
 640
 641       if (EQ (subtype, Qhash) || NILP (subtype))
 642         real_subtype = DB_HASH;
 643       else if (EQ (subtype, Qbtree))
 644         real_subtype = DB_BTREE;
 645       else if (EQ (subtype, Qrecno))
 646         real_subtype = DB_RECNO;
 647       else
 648         signal_simple_error ("Unsupported subtype", subtype);
 649
 650 #if DB_VERSION_MAJOR == 1
 651       dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
 652       if (!dbase)
 653         return Qnil;
 654 #else
 655       /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 656          other flags shouldn't be set */
 657       if (NILP (access_))
 658         accessmask = DB_CREATE;
 659       else
 660         {
 661           char *acc;
 662           CHECK_STRING (access_);
 663           acc = (char *) XSTRING_DATA (access_);
 664           accessmask = 0;
 665
 666           if (strchr (acc, '+'))
 667             accessmask |= DB_CREATE;
 668
 669           if (strchr (acc, 'r') && !strchr (acc, 'w'))
 670             accessmask |= DB_RDONLY;
 671         }
 672       status = db_open (filename, real_subtype, accessmask,
 673                         modemask, NULL , NULL, &dbase);
 674       if (status)
 675         return Qnil;
 676 #endif /* DB_VERSION_MAJOR */
 677
 678       db = allocate_database ();
 679       db->db_handle = dbase;
 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     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     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     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
 799 #if 0 /* #### implement me! */
 800 #ifdef MULE
 801   DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
 802 Coding system used to convert data in database files.
 803 */ );
 804   Vdatabase_coding_system = Qnil;
 805 #endif
 806 #endif /* 0 */
 807 }