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 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 obj)
 148 {
 149   Lisp_Database *db = XDATABASE (obj);
 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 obj;
 182       XSETDATABASE (obj, db);
 183
 184       signal_simple_error
 185         ("Can't dump an emacs containing database objects", obj);
 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 OBJ is an active database.
 230 */
 231        (obj))
 232 {
 233   return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
 234 }
 235
 236 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
 237 Return the filename associated with the database DATABASE.
 238 */
 239        (database))
 240 {
 241   CHECK_DATABASE (database);
 242
 243   return XDATABASE (database)->fname;
 244 }
 245
 246 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
 247 Return t if OBJ is a database.
 248 */
 249        (obj))
 250 {
 251   return DATABASEP (obj) ? Qt : Qnil;
 252 }
 253
 254 #ifdef HAVE_DBM
 255 static void
 256 dbm_map (Lisp_Database *db, Lisp_Object func)
 257 {
 258   datum keydatum, valdatum;
 259   Lisp_Object key, val;
 260
 261   for (keydatum = dbm_firstkey (db->dbm_handle);
 262        keydatum.dptr != NULL;
 263        keydatum = dbm_nextkey (db->dbm_handle))
 264     {
 265       valdatum = dbm_fetch (db->dbm_handle, keydatum);
 266       key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
 267       val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
 268       call2 (func, key, val);
 269     }
 270 }
 271
 272 static Lisp_Object
 273 dbm_get (Lisp_Database *db, Lisp_Object key)
 274 {
 275   datum keydatum, valdatum;
 276
 277   keydatum.dptr = (char *) XSTRING_DATA (key);
 278   keydatum.dsize = XSTRING_LENGTH (key);
 279   valdatum = dbm_fetch (db->dbm_handle, keydatum);
 280
 281   return (valdatum.dptr
 282           ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
 283           : Qnil);
 284 }
 285
 286 static int
 287 dbm_put (Lisp_Database *db,
 288          Lisp_Object key, Lisp_Object val, Lisp_Object replace)
 289 {
 290   datum keydatum, valdatum;
 291
 292   valdatum.dptr = (char *) XSTRING_DATA (val);
 293   valdatum.dsize = XSTRING_LENGTH (val);
 294   keydatum.dptr = (char *) XSTRING_DATA (key);
 295   keydatum.dsize = XSTRING_LENGTH (key);
 296
 297   return !dbm_store (db->dbm_handle, keydatum, valdatum,
 298                      NILP (replace) ? DBM_INSERT : DBM_REPLACE);
 299 }
 300
 301 static int
 302 dbm_remove (Lisp_Database *db, Lisp_Object key)
 303 {
 304   datum keydatum;
 305
 306   keydatum.dptr = (char *) XSTRING_DATA (key);
 307   keydatum.dsize = XSTRING_LENGTH (key);
 308
 309   return dbm_delete (db->dbm_handle, keydatum);
 310 }
 311
 312 static Lisp_Object
 313 dbm_type (Lisp_Database *db)
 314 {
 315   return Qdbm;
 316 }
 317
 318 static Lisp_Object
 319 dbm_subtype (Lisp_Database *db)
 320 {
 321   return Qnil;
 322 }
 323
 324 static Lisp_Object
 325 dbm_lasterr (Lisp_Database *db)
 326 {
 327   return lisp_strerror (db->dberrno);
 328 }
 329
 330 static void
 331 dbm_closeit (Lisp_Database *db)
 332 {
 333   if (db->dbm_handle)
 334     {
 335       dbm_close (db->dbm_handle);
 336       db->dbm_handle = NULL;
 337     }
 338 }
 339
 340 static DB_FUNCS ndbm_func_block =
 341 {
 342   dbm_subtype,
 343   dbm_type,
 344   dbm_get,
 345   dbm_put,
 346   dbm_remove,
 347   dbm_map,
 348   dbm_closeit,
 349   dbm_lasterr
 350 };
 351 #endif /* HAVE_DBM */
 352
 353 #ifdef HAVE_BERKELEY_DB
 354 static Lisp_Object
 355 berkdb_type (Lisp_Database *db)
 356 {
 357   return Qberkeley_db;
 358 }
 359
 360 static Lisp_Object
 361 berkdb_subtype (Lisp_Database *db)
 362 {
 363   if (!db->db_handle)
 364     return Qnil;
 365
 366   switch (db->db_handle->type)
 367     {
 368     case DB_BTREE: return Qbtree;
 369     case DB_HASH:  return Qhash;
 370     case DB_RECNO: return Qrecno;
 371     default:       return Qunknown;
 372     }
 373 }
 374
 375 static Lisp_Object
 376 berkdb_lasterr (Lisp_Database *db)
 377 {
 378   return lisp_strerror (db->dberrno);
 379 }
 380
 381 static Lisp_Object
 382 berkdb_get (Lisp_Database *db, Lisp_Object key)
 383 {
 384   DBT keydatum, valdatum;
 385   int status = 0;
 386
 387   /* DB Version 2 requires DBT's to be zeroed before use. */
 388   xzero (keydatum);
 389   xzero (valdatum);
 390
 391   keydatum.data = XSTRING_DATA (key);
 392   keydatum.size = XSTRING_LENGTH (key);
 393
 394 #if DB_VERSION_MAJOR == 1
 395   status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
 396 #else
 397   status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
 398 #endif /* DB_VERSION_MAJOR */
 399
 400   if (!status)
 401     /* #### Not mule-ized! will crash! */
 402     return make_string ((Bufbyte *) valdatum.data, valdatum.size);
 403
 404 #if DB_VERSION_MAJOR == 1
 405   db->dberrno = (status == 1) ? -1 : errno;
 406 #else
 407   db->dberrno = (status < 0) ? -1 : errno;
 408 #endif /* DB_VERSION_MAJOR */
 409
 410   return Qnil;
 411 }
 412
 413 static int
 414 berkdb_put (Lisp_Database *db,
 415             Lisp_Object key,
 416             Lisp_Object val,
 417             Lisp_Object replace)
 418 {
 419   DBT keydatum, valdatum;
 420   int status = 0;
 421
 422   /* DB Version 2 requires DBT's to be zeroed before use. */
 423   xzero (keydatum);
 424   xzero (valdatum);
 425
 426   keydatum.data = XSTRING_DATA   (key);
 427   keydatum.size = XSTRING_LENGTH (key);
 428   valdatum.data = XSTRING_DATA   (val);
 429   valdatum.size = XSTRING_LENGTH (val);
 430 #if DB_VERSION_MAJOR == 1
 431   status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
 432                                NILP (replace) ? R_NOOVERWRITE : 0);
 433   db->dberrno = (status == 1) ? -1 : errno;
 434 #else
 435   status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
 436                                NILP (replace) ? DB_NOOVERWRITE : 0);
 437   db->dberrno = (status < 0) ? -1 : errno;
 438 #endif/* DV_VERSION_MAJOR = 2 */
 439
 440   return status;
 441 }
 442
 443 static int
 444 berkdb_remove (Lisp_Database *db, Lisp_Object key)
 445 {
 446   DBT keydatum;
 447   int status;
 448
 449   /* DB Version 2 requires DBT's to be zeroed before use. */
 450   xzero (keydatum);
 451
 452   keydatum.data = XSTRING_DATA   (key);
 453   keydatum.size = XSTRING_LENGTH (key);
 454
 455 #if DB_VERSION_MAJOR == 1
 456   status = db->db_handle->del (db->db_handle, &keydatum, 0);
 457 #else
 458   status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
 459 #endif /* DB_VERSION_MAJOR */
 460
 461   if (!status)
 462     return 0;
 463
 464 #if DB_VERSION_MAJOR == 1
 465   db->dberrno = (status == 1) ? -1 : errno;
 466 #else
 467   db->dberrno = (status < 0) ? -1 : errno;
 468 #endif /* DB_VERSION_MAJOR */
 469
 470   return 1;
 471 }
 472
 473 static void
 474 berkdb_map (Lisp_Database *db, Lisp_Object func)
 475 {
 476   DBT keydatum, valdatum;
 477   Lisp_Object key, val;
 478   DB *dbp = db->db_handle;
 479   int status;
 480
 481   xzero (keydatum);
 482   xzero (valdatum);
 483
 484 #if DB_VERSION_MAJOR == 1
 485   for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
 486        status == 0;
 487        status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
 488     {
 489       /* #### Needs mule-izing */
 490       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 491       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 492       call2 (func, key, val);
 493     }
 494 #else
 495   {
 496     DBC *dbcp;
 497
 498 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
 499     status = dbp->cursor (dbp, NULL, &dbcp, 0);
 500 #else
 501     status = dbp->cursor (dbp, NULL, &dbcp);
 502 #endif
 503     for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
 504          status == 0;
 505          status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
 506       {
 507         /* #### Needs mule-izing */
 508         key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 509         val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 510         call2 (func, key, val);
 511       }
 512     dbcp->c_close (dbcp);
 513   }
 514 #endif /* DB_VERSION_MAJOR */
 515 }
 516
 517 static void
 518 berkdb_close (Lisp_Database *db)
 519 {
 520   if (db->db_handle)
 521     {
 522 #if DB_VERSION_MAJOR == 1
 523       db->db_handle->sync  (db->db_handle, 0);
 524       db->db_handle->close (db->db_handle);
 525 #else
 526       db->db_handle->sync  (db->db_handle, 0);
 527       db->db_handle->close (db->db_handle, 0);
 528 #endif /* DB_VERSION_MAJOR */
 529       db->db_handle = NULL;
 530     }
 531 }
 532
 533 static DB_FUNCS berk_func_block =
 534 {
 535   berkdb_subtype,
 536   berkdb_type,
 537   berkdb_get,
 538   berkdb_put,
 539   berkdb_remove,
 540   berkdb_map,
 541   berkdb_close,
 542   berkdb_lasterr
 543 };
 544 #endif /* HAVE_BERKELEY_DB */
 545
 546 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 547 Return the last error associated with DATABASE.
 548 */
 549        (database))
 550 {
 551   if (NILP (database))
 552     return lisp_strerror (errno);
 553
 554   CHECK_DATABASE (database);
 555
 556   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 557 }
 558
 559 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 560 Return a new database object opened on FILE.
 561 Optional arguments TYPE and SUBTYPE specify the database type.
 562 Optional argument ACCESS specifies the access rights, which may be any
 563 combination of 'r' 'w' and '+', for read, write, and creation flags.
 564 Optional argument MODE gives the permissions to use when opening FILE,
 565 and defaults to 0755.
 566 */
 567        (file, type, subtype, access_, mode))
 568 {
 569   /* This function can GC */
 570   int modemask;
 571   int accessmask = 0;
 572   Lisp_Database *db = NULL;
 573   char *filename;
 574   struct gcpro gcpro1, gcpro2;
 575
 576   CHECK_STRING (file);
 577   GCPRO2 (file, access_);
 578   file = Fexpand_file_name (file, Qnil);
 579   UNGCPRO;
 580
 581   TO_EXTERNAL_FORMAT (LISP_STRING, file,
 582                       C_STRING_ALLOCA, filename,
 583                       Qfile_name);
 584
 585   if (NILP (access_))
 586     {
 587       accessmask = O_RDWR | O_CREAT;
 588     }
 589   else
 590     {
 591       char *acc;
 592       CHECK_STRING (access_);
 593       acc = (char *) XSTRING_DATA (access_);
 594
 595       if (strchr (acc, '+'))
 596         accessmask |= O_CREAT;
 597
 598       {
 599         char *rp = strchr (acc, 'r');
 600         char *wp = strchr (acc, 'w');
 601         if (rp && wp) accessmask |= O_RDWR;
 602         else if (wp)  accessmask |= O_WRONLY;
 603         else          accessmask |= O_RDONLY;
 604       }
 605     }
 606
 607   if (NILP (mode))
 608     {
 609       modemask = 0755;          /* rwxr-xr-x */
 610     }
 611   else
 612     {
 613       CHECK_INT (mode);
 614       modemask = XINT (mode);
 615     }
 616
 617 #ifdef HAVE_DBM
 618   if (NILP (type) || EQ (type, Qdbm))
 619     {
 620       DBM *dbase = dbm_open (filename, accessmask, modemask);
 621       if (!dbase)
 622         return Qnil;
 623
 624       db = allocate_database ();
 625       db->dbm_handle = dbase;
 626       db->funcs = &ndbm_func_block;
 627       goto db_done;
 628     }
 629 #endif /* HAVE_DBM */
 630
 631 #ifdef HAVE_BERKELEY_DB
 632   if (NILP (type) || EQ (type, Qberkeley_db))
 633     {
 634       DBTYPE real_subtype;
 635       DB *dbase;
 636 #if DB_VERSION_MAJOR != 1
 637       int status;
 638 #endif
 639
 640       if (EQ (subtype, Qhash) || NILP (subtype))
 641         real_subtype = DB_HASH;
 642       else if (EQ (subtype, Qbtree))
 643         real_subtype = DB_BTREE;
 644       else if (EQ (subtype, Qrecno))
 645         real_subtype = DB_RECNO;
 646       else
 647         signal_simple_error ("Unsupported subtype", subtype);
 648
 649 #if DB_VERSION_MAJOR == 1
 650       dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
 651       if (!dbase)
 652         return Qnil;
 653 #else
 654       /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 655          other flags shouldn't be set */
 656       if (NILP (access_))
 657         accessmask = DB_CREATE;
 658       else
 659         {
 660           char *acc;
 661           CHECK_STRING (access_);
 662           acc = (char *) XSTRING_DATA (access_);
 663           accessmask = 0;
 664
 665           if (strchr (acc, '+'))
 666             accessmask |= DB_CREATE;
 667
 668           if (strchr (acc, 'r') && !strchr (acc, 'w'))
 669             accessmask |= DB_RDONLY;
 670         }
 671       status = db_open (filename, real_subtype, accessmask,
 672                         modemask, NULL , NULL, &dbase);
 673       if (status)
 674         return Qnil;
 675 #endif /* DB_VERSION_MAJOR */
 676
 677       db = allocate_database ();
 678       db->db_handle = dbase;
 679       db->funcs = &berk_func_block;
 680       goto db_done;
 681     }
 682 #endif /* HAVE_BERKELEY_DB */
 683
 684   signal_simple_error ("Unsupported database type", type);
 685   return Qnil;
 686
 687  db_done:
 688   db->live_p = 1;
 689   db->fname = file;
 690   db->mode = modemask;
 691   db->access_ = accessmask;
 692
 693   {
 694     Lisp_Object retval;
 695     XSETDATABASE (retval, db);
 696     return retval;
 697   }
 698 }
 699
 700 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
 701 Store KEY and VALUE in DATABASE.
 702 If optional fourth arg REPLACE is non-nil,
 703 replace any existing entry in the database.
 704 */
 705        (key, value, database, replace))
 706 {
 707   CHECK_LIVE_DATABASE (database);
 708   CHECK_STRING (key);
 709   CHECK_STRING (value);
 710   {
 711     Lisp_Database *db = XDATABASE (database);
 712     int status = db->funcs->put (db, key, value, replace);
 713     return status ? Qt : Qnil;
 714   }
 715 }
 716
 717 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
 718 Remove KEY from DATABASE.
 719 */
 720        (key, database))
 721 {
 722   CHECK_LIVE_DATABASE (database);
 723   CHECK_STRING (key);
 724   {
 725     Lisp_Database *db = XDATABASE (database);
 726     int status = db->funcs->rem (db, key);
 727     return status ? Qt : Qnil;
 728   }
 729 }
 730
 731 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
 732 Return value for KEY in DATABASE.
 733 If there is no corresponding value, return DEFAULT (defaults to nil).
 734 */
 735        (key, database, default_))
 736 {
 737   CHECK_LIVE_DATABASE (database);
 738   CHECK_STRING (key);
 739   {
 740     Lisp_Database *db = XDATABASE (database);
 741     Lisp_Object retval = db->funcs->get (db, key);
 742     return NILP (retval) ? default_ : retval;
 743   }
 744 }
 745
 746 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
 747 Map FUNCTION over entries in DATABASE, calling it with two args,
 748 each key and value in the database.
 749 */
 750        (function, database))
 751 {
 752   CHECK_LIVE_DATABASE (database);
 753
 754   XDATABASE (database)->funcs->map (XDATABASE (database), function);
 755
 756   return Qnil;
 757 }
 758
 759 void
 760 syms_of_database (void)
 761 {
 762   INIT_LRECORD_IMPLEMENTATION (database);
 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 }