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_FILE              /* 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 typedef struct
  79 {
  80   Lisp_Object (*get_subtype) (Lisp_Database *);
  81   Lisp_Object (*get_type) (Lisp_Database *);
  82   Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
  83   int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
  84   int (*rem) (Lisp_Database *, Lisp_Object);
  85   void (*map) (Lisp_Database *, Lisp_Object);
  86   void (*close) (Lisp_Database *);
  87   Lisp_Object (*last_error) (Lisp_Database *);
  88 } DB_FUNCS;
  89
  90 struct Lisp_Database
  91 {
  92   struct lcrecord_header header;
  93   Lisp_Object fname;
  94   int mode;
  95   int access_;
  96   int dberrno;
  97   int live_p;
  98 #ifdef HAVE_DBM
  99   DBM *dbm_handle;
 100 #endif
 101 #ifdef HAVE_BERKELEY_DB
 102   DB *db_handle;
 103 #endif
 104   DB_FUNCS *funcs;
 105 #ifdef MULE
 106   Lisp_Object coding_system;
 107 #endif
 108 };
 109
 110 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
 111 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
 112 #define DATABASEP(x) RECORDP (x, database)
 113 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
 114 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
 115 #define DATABASE_LIVE_P(x) (x->live_p)
 116
 117 #define CHECK_LIVE_DATABASE(db) do {                                    \
 118   CHECK_DATABASE (db);                                                  \
 119   if (!DATABASE_LIVE_P (XDATABASE(db)))                                 \
 120     signal_simple_error ("Attempting to access closed database", db);   \
 121 } while (0)
 122
 123
 124 static Lisp_Database *
 125 allocate_database (void)
 126 {
 127   Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
 128
 129   db->fname = Qnil;
 130   db->live_p = 0;
 131 #ifdef HAVE_BERKELEY_DB
 132   db->db_handle = NULL;
 133 #endif
 134 #ifdef HAVE_DBM
 135   db->dbm_handle = NULL;
 136 #endif
 137   db->access_ = 0;
 138   db->mode = 0;
 139   db->dberrno = 0;
 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 object)
 148 {
 149   Lisp_Database *db = XDATABASE (object);
 150   return db->fname;
 151 }
 152
 153 static void
 154 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 155 {
 156   char buf[64];
 157   Lisp_Database *db = XDATABASE (obj);
 158
 159   if (print_readably)
 160     error ("printing unreadable object #<database 0x%x>", db->header.uid);
 161
 162   write_c_string ("#<database \"", printcharfun);
 163   print_internal (db->fname, printcharfun, 0);
 164   sprintf (buf, "\" (%s/%s/%s) 0x%x>",
 165            (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
 166            (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
 167            (!DATABASE_LIVE_P (db)    ? "closed"    :
 168             (db->access_ & O_WRONLY) ? "writeonly" :
 169             (db->access_ & O_RDWR)   ? "readwrite" : "readonly"),
 170            db->header.uid);
 171   write_c_string (buf, printcharfun);
 172 }
 173
 174 static void
 175 finalize_database (void *header, int for_disksave)
 176 {
 177   Lisp_Database *db = (Lisp_Database *) header;
 178
 179   if (for_disksave)
 180     {
 181       Lisp_Object object;
 182       XSETDATABASE (object, db);
 183
 184       signal_simple_error
 185         ("Can't dump an emacs containing database objects", object);
 186     }
 187   db->funcs->close (db);
 188 }
 189
 190 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
 191                                mark_database, print_database,
 192                                finalize_database, 0, 0, 0,
 193                                Lisp_Database);
 194
 195 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
 196 Close database DATABASE.
 197 */
 198        (database))
 199 {
 200   Lisp_Database *db;
 201   CHECK_LIVE_DATABASE (database);
 202   db = XDATABASE (database);
 203   db->funcs->close (db);
 204   db->live_p = 0;
 205   return Qnil;
 206 }
 207
 208 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
 209 Return the type of database DATABASE.
 210 */
 211        (database))
 212 {
 213   CHECK_DATABASE (database);
 214
 215   return XDATABASE (database)->funcs->get_type (XDATABASE (database));
 216 }
 217
 218 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
 219 Return the subtype of database DATABASE, if any.
 220 */
 221        (database))
 222 {
 223   CHECK_DATABASE (database);
 224
 225   return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
 226 }
 227
 228 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
 229 Return t if OBJECT is an active database.
 230 */
 231        (object))
 232 {
 233   return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
 234     Qt : Qnil;
 235 }
 236
 237 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
 238 Return the filename associated with the database DATABASE.
 239 */
 240        (database))
 241 {
 242   CHECK_DATABASE (database);
 243
 244   return XDATABASE (database)->fname;
 245 }
 246
 247 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
 248 Return t if OBJECT is a database.
 249 */
 250        (object))
 251 {
 252   return DATABASEP (object) ? Qt : Qnil;
 253 }
 254
 255 #ifdef HAVE_DBM
 256 static void
 257 dbm_map (Lisp_Database *db, Lisp_Object func)
 258 {
 259   datum keydatum, valdatum;
 260   Lisp_Object key, val;
 261
 262   for (keydatum = dbm_firstkey (db->dbm_handle);
 263        keydatum.dptr != NULL;
 264        keydatum = dbm_nextkey (db->dbm_handle))
 265     {
 266       valdatum = dbm_fetch (db->dbm_handle, keydatum);
 267       key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
 268       val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
 269       call2 (func, key, val);
 270     }
 271 }
 272
 273 static Lisp_Object
 274 dbm_get (Lisp_Database *db, Lisp_Object key)
 275 {
 276   datum keydatum, valdatum;
 277
 278   keydatum.dptr = (char *) XSTRING_DATA (key);
 279   keydatum.dsize = XSTRING_LENGTH (key);
 280   valdatum = dbm_fetch (db->dbm_handle, keydatum);
 281
 282   return (valdatum.dptr
 283           ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
 284           : Qnil);
 285 }
 286
 287 static int
 288 dbm_put (Lisp_Database *db,
 289          Lisp_Object key, Lisp_Object val, Lisp_Object replace)
 290 {
 291   datum keydatum, valdatum;
 292
 293   valdatum.dptr = (char *) XSTRING_DATA (val);
 294   valdatum.dsize = XSTRING_LENGTH (val);
 295   keydatum.dptr = (char *) XSTRING_DATA (key);
 296   keydatum.dsize = XSTRING_LENGTH (key);
 297
 298   return !dbm_store (db->dbm_handle, keydatum, valdatum,
 299                      NILP (replace) ? DBM_INSERT : DBM_REPLACE);
 300 }
 301
 302 static int
 303 dbm_remove (Lisp_Database *db, Lisp_Object key)
 304 {
 305   datum keydatum;
 306
 307   keydatum.dptr = (char *) XSTRING_DATA (key);
 308   keydatum.dsize = XSTRING_LENGTH (key);
 309
 310   return dbm_delete (db->dbm_handle, keydatum);
 311 }
 312
 313 static Lisp_Object
 314 dbm_type (Lisp_Database *db)
 315 {
 316   return Qdbm;
 317 }
 318
 319 static Lisp_Object
 320 dbm_subtype (Lisp_Database *db)
 321 {
 322   return Qnil;
 323 }
 324
 325 static Lisp_Object
 326 dbm_lasterr (Lisp_Database *db)
 327 {
 328   return lisp_strerror (db->dberrno);
 329 }
 330
 331 static void
 332 dbm_closeit (Lisp_Database *db)
 333 {
 334   if (db->dbm_handle)
 335     {
 336       dbm_close (db->dbm_handle);
 337       db->dbm_handle = NULL;
 338     }
 339 }
 340
 341 static DB_FUNCS ndbm_func_block =
 342 {
 343   dbm_subtype,
 344   dbm_type,
 345   dbm_get,
 346   dbm_put,
 347   dbm_remove,
 348   dbm_map,
 349   dbm_closeit,
 350   dbm_lasterr
 351 };
 352 #endif /* HAVE_DBM */
 353
 354 #ifdef HAVE_BERKELEY_DB
 355 static Lisp_Object
 356 berkdb_type (Lisp_Database *db)
 357 {
 358   return Qberkeley_db;
 359 }
 360
 361 static Lisp_Object
 362 berkdb_subtype (Lisp_Database *db)
 363 {
 364   if (!db->db_handle)
 365     return Qnil;
 366
 367   switch (db->db_handle->type)
 368     {
 369     case DB_BTREE: return Qbtree;
 370     case DB_HASH:  return Qhash;
 371     case DB_RECNO: return Qrecno;
 372     default:       return Qunknown;
 373     }
 374 }
 375
 376 static Lisp_Object
 377 berkdb_lasterr (Lisp_Database *db)
 378 {
 379   return lisp_strerror (db->dberrno);
 380 }
 381
 382 static Lisp_Object
 383 berkdb_get (Lisp_Database *db, Lisp_Object key)
 384 {
 385   DBT keydatum, valdatum;
 386   int status = 0;
 387
 388   /* DB Version 2 requires DBT's to be zeroed before use. */
 389   xzero (keydatum);
 390   xzero (valdatum);
 391
 392   keydatum.data = XSTRING_DATA (key);
 393   keydatum.size = XSTRING_LENGTH (key);
 394
 395 #if DB_VERSION_MAJOR == 1
 396   status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
 397 #else
 398   status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
 399 #endif /* DB_VERSION_MAJOR */
 400
 401   if (!status)
 402     /* #### Not mule-ized! will crash! */
 403     return make_string ((Bufbyte *) valdatum.data, valdatum.size);
 404
 405 #if DB_VERSION_MAJOR == 1
 406   db->dberrno = (status == 1) ? -1 : errno;
 407 #else
 408   db->dberrno = (status < 0) ? -1 : errno;
 409 #endif /* DB_VERSION_MAJOR */
 410
 411   return Qnil;
 412 }
 413
 414 static int
 415 berkdb_put (Lisp_Database *db,
 416             Lisp_Object key,
 417             Lisp_Object val,
 418             Lisp_Object replace)
 419 {
 420   DBT keydatum, valdatum;
 421   int status = 0;
 422
 423   /* DB Version 2 requires DBT's to be zeroed before use. */
 424   xzero (keydatum);
 425   xzero (valdatum);
 426
 427   keydatum.data = XSTRING_DATA   (key);
 428   keydatum.size = XSTRING_LENGTH (key);
 429   valdatum.data = XSTRING_DATA   (val);
 430   valdatum.size = XSTRING_LENGTH (val);
 431 #if DB_VERSION_MAJOR == 1
 432   status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
 433                                NILP (replace) ? R_NOOVERWRITE : 0);
 434   db->dberrno = (status == 1) ? -1 : errno;
 435 #else
 436   status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
 437                                NILP (replace) ? DB_NOOVERWRITE : 0);
 438   db->dberrno = (status < 0) ? -1 : errno;
 439 #endif/* DV_VERSION_MAJOR = 2 */
 440
 441   return status;
 442 }
 443
 444 static int
 445 berkdb_remove (Lisp_Database *db, Lisp_Object key)
 446 {
 447   DBT keydatum;
 448   int status;
 449
 450   /* DB Version 2 requires DBT's to be zeroed before use. */
 451   xzero (keydatum);
 452
 453   keydatum.data = XSTRING_DATA   (key);
 454   keydatum.size = XSTRING_LENGTH (key);
 455
 456 #if DB_VERSION_MAJOR == 1
 457   status = db->db_handle->del (db->db_handle, &keydatum, 0);
 458 #else
 459   status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
 460 #endif /* DB_VERSION_MAJOR */
 461
 462   if (!status)
 463     return 0;
 464
 465 #if DB_VERSION_MAJOR == 1
 466   db->dberrno = (status == 1) ? -1 : errno;
 467 #else
 468   db->dberrno = (status < 0) ? -1 : errno;
 469 #endif /* DB_VERSION_MAJOR */
 470
 471   return 1;
 472 }
 473
 474 static void
 475 berkdb_map (Lisp_Database *db, Lisp_Object func)
 476 {
 477   DBT keydatum, valdatum;
 478   Lisp_Object key, val;
 479   DB *dbp = db->db_handle;
 480   int status;
 481
 482   xzero (keydatum);
 483   xzero (valdatum);
 484
 485 #if DB_VERSION_MAJOR == 1
 486   for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
 487        status == 0;
 488        status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
 489     {
 490       /* #### Needs mule-izing */
 491       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 492       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 493       call2 (func, key, val);
 494     }
 495 #else
 496   {
 497     DBC *dbcp;
 498
 499 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
 500     status = dbp->cursor (dbp, NULL, &dbcp, 0);
 501 #else
 502     status = dbp->cursor (dbp, NULL, &dbcp);
 503 #endif
 504     for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
 505          status == 0;
 506          status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
 507       {
 508         /* #### Needs mule-izing */
 509         key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 510         val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 511         call2 (func, key, val);
 512       }
 513     dbcp->c_close (dbcp);
 514   }
 515 #endif /* DB_VERSION_MAJOR */
 516 }
 517
 518 static void
 519 berkdb_close (Lisp_Database *db)
 520 {
 521   if (db->db_handle)
 522     {
 523 #if DB_VERSION_MAJOR == 1
 524       db->db_handle->sync  (db->db_handle, 0);
 525       db->db_handle->close (db->db_handle);
 526 #else
 527       db->db_handle->sync  (db->db_handle, 0);
 528       db->db_handle->close (db->db_handle, 0);
 529 #endif /* DB_VERSION_MAJOR */
 530       db->db_handle = NULL;
 531     }
 532 }
 533
 534 static DB_FUNCS berk_func_block =
 535 {
 536   berkdb_subtype,
 537   berkdb_type,
 538   berkdb_get,
 539   berkdb_put,
 540   berkdb_remove,
 541   berkdb_map,
 542   berkdb_close,
 543   berkdb_lasterr
 544 };
 545 #endif /* HAVE_BERKELEY_DB */
 546
 547 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 548 Return the last error associated with DATABASE.
 549 */
 550        (database))
 551 {
 552   if (NILP (database))
 553     return lisp_strerror (errno);
 554
 555   CHECK_DATABASE (database);
 556
 557   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 558 }
 559
 560 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 561 Return a new database object opened on FILE.
 562 Optional arguments TYPE and SUBTYPE specify the database type.
 563 Optional argument ACCESS specifies the access rights, which may be any
 564 combination of 'r' 'w' and '+', for read, write, and creation flags.
 565 Optional argument MODE gives the permissions to use when opening FILE,
 566 and defaults to 0755.
 567 */
 568        (file, type, subtype, access_, mode))
 569 {
 570   /* This function can GC */
 571   int modemask;
 572   int accessmask = 0;
 573   Lisp_Database *db = NULL;
 574   char *filename;
 575   struct gcpro gcpro1, gcpro2;
 576
 577   CHECK_STRING (file);
 578   GCPRO2 (file, access_);
 579   file = Fexpand_file_name (file, Qnil);
 580   UNGCPRO;
 581
 582   TO_EXTERNAL_FORMAT (LISP_STRING, file,
 583                       C_STRING_ALLOCA, filename,
 584                       Qfile_name);
 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   INIT_LRECORD_IMPLEMENTATION (database);
 764
 765   defsymbol (&Qdatabasep, "databasep");
 766 #ifdef HAVE_DBM
 767   defsymbol (&Qdbm, "dbm");
 768 #endif
 769 #ifdef HAVE_BERKELEY_DB
 770   defsymbol (&Qberkeley_db, "berkeley-db");
 771   defsymbol (&Qhash, "hash");
 772   defsymbol (&Qbtree, "btree");
 773   defsymbol (&Qrecno, "recno");
 774   defsymbol (&Qunknown, "unknown");
 775 #endif
 776
 777   DEFSUBR (Fopen_database);
 778   DEFSUBR (Fdatabasep);
 779   DEFSUBR (Fmapdatabase);
 780   DEFSUBR (Fput_database);
 781   DEFSUBR (Fget_database);
 782   DEFSUBR (Fremove_database);
 783   DEFSUBR (Fdatabase_type);
 784   DEFSUBR (Fdatabase_subtype);
 785   DEFSUBR (Fdatabase_last_error);
 786   DEFSUBR (Fdatabase_live_p);
 787   DEFSUBR (Fdatabase_file_name);
 788   DEFSUBR (Fclose_database);
 789 }
 790
 791 void
 792 vars_of_database (void)
 793 {
 794 #ifdef HAVE_DBM
 795   Fprovide (Qdbm);
 796 #endif
 797 #ifdef HAVE_BERKELEY_DB
 798   Fprovide (Qberkeley_db);
 799 #endif
 800
 801 #if 0 /* #### implement me! */
 802 #ifdef MULE
 803   DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
 804 Coding system used to convert data in database files.
 805 */ );
 806   Vdatabase_coding_system = Qnil;
 807 #endif
 808 #endif /* 0 */
 809 }