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