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