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 #if DB_VERSION_MAJOR > 2
  63 Lisp_Object Qqueue;
  64 #endif
  65 #endif /* HAVE_BERKELEY_DB */
  66
  67 #ifdef HAVE_DBM
  68 #include <ndbm.h>
  69 Lisp_Object Qdbm;
  70 #endif /* HAVE_DBM */
  71
  72 #ifdef MULE
  73 /* #### The following should be settable on a per-database level.
  74    But the whole coding-system infrastructure should be rewritten someday.
  75    We really need coding-system aliases. -- martin */
  76 Lisp_Object Vdatabase_coding_system;
  77 #endif
  78
  79 Lisp_Object Qdatabasep;
  80
  81 typedef struct
  82 {
  83   Lisp_Object (*get_subtype) (Lisp_Database *);
  84   Lisp_Object (*get_type) (Lisp_Database *);
  85   Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
  86   int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
  87   int (*rem) (Lisp_Database *, Lisp_Object);
  88   void (*map) (Lisp_Database *, Lisp_Object);
  89   void (*close) (Lisp_Database *);
  90   Lisp_Object (*last_error) (Lisp_Database *);
  91 } DB_FUNCS;
  92
  93 struct Lisp_Database
  94 {
  95   struct lcrecord_header header;
  96   Lisp_Object fname;
  97   int mode;
  98   int access_;
  99   int dberrno;
 100   int live_p;
 101 #ifdef HAVE_DBM
 102   DBM *dbm_handle;
 103 #endif
 104 #ifdef HAVE_BERKELEY_DB
 105   DB *db_handle;
 106 #endif
 107   DB_FUNCS *funcs;
 108 #ifdef MULE
 109   Lisp_Object coding_system;
 110 #endif
 111 };
 112
 113 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
 114 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
 115 #define DATABASEP(x) RECORDP (x, database)
 116 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
 117 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
 118 #define DATABASE_LIVE_P(x) (x->live_p)
 119
 120 #define CHECK_LIVE_DATABASE(db) do {                                    \
 121   CHECK_DATABASE (db);                                                  \
 122   if (!DATABASE_LIVE_P (XDATABASE(db)))                                 \
 123     signal_simple_error ("Attempting to access closed database", db);   \
 124 } while (0)
 125
 126
 127 static Lisp_Database *
 128 allocate_database (void)
 129 {
 130   Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
 131
 132   db->fname = Qnil;
 133   db->live_p = 0;
 134 #ifdef HAVE_BERKELEY_DB
 135   db->db_handle = NULL;
 136 #endif
 137 #ifdef HAVE_DBM
 138   db->dbm_handle = NULL;
 139 #endif
 140   db->access_ = 0;
 141   db->mode = 0;
 142   db->dberrno = 0;
 143 #ifdef MULE
 144   db->coding_system = Fget_coding_system (Qbinary);
 145 #endif
 146   return db;
 147 }
 148
 149 static Lisp_Object
 150 mark_database (Lisp_Object object)
 151 {
 152   Lisp_Database *db = XDATABASE (object);
 153   return db->fname;
 154 }
 155
 156 static void
 157 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 158 {
 159   char buf[64];
 160   Lisp_Database *db = XDATABASE (obj);
 161
 162   if (print_readably)
 163     error ("printing unreadable object #<database 0x%x>", db->header.uid);
 164
 165   write_c_string ("#<database \"", printcharfun);
 166   print_internal (db->fname, printcharfun, 0);
 167   sprintf (buf, "\" (%s/%s/%s) 0x%x>",
 168            (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
 169            (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
 170            (!DATABASE_LIVE_P (db)    ? "closed"    :
 171             (db->access_ & O_WRONLY) ? "writeonly" :
 172             (db->access_ & O_RDWR)   ? "readwrite" : "readonly"),
 173            db->header.uid);
 174   write_c_string (buf, printcharfun);
 175 }
 176
 177 static void
 178 finalize_database (void *header, int for_disksave)
 179 {
 180   Lisp_Database *db = (Lisp_Database *) header;
 181
 182   if (for_disksave)
 183     {
 184       Lisp_Object object;
 185       XSETDATABASE (object, db);
 186
 187       signal_simple_error
 188         ("Can't dump an emacs containing database objects", object);
 189     }
 190   db->funcs->close (db);
 191 }
 192
 193 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
 194                                mark_database, print_database,
 195                                finalize_database, 0, 0, 0,
 196                                Lisp_Database);
 197
 198 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
 199 Close database DATABASE.
 200 */
 201        (database))
 202 {
 203   Lisp_Database *db;
 204   CHECK_LIVE_DATABASE (database);
 205   db = XDATABASE (database);
 206   db->funcs->close (db);
 207   db->live_p = 0;
 208   return Qnil;
 209 }
 210
 211 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
 212 Return the type of database DATABASE.
 213 */
 214        (database))
 215 {
 216   CHECK_DATABASE (database);
 217
 218   return XDATABASE (database)->funcs->get_type (XDATABASE (database));
 219 }
 220
 221 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
 222 Return the subtype of database DATABASE, if any.
 223 */
 224        (database))
 225 {
 226   CHECK_DATABASE (database);
 227
 228   return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
 229 }
 230
 231 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
 232 Return t if OBJECT is an active database.
 233 */
 234        (object))
 235 {
 236   return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
 237     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 OBJECT is a database.
 252 */
 253        (object))
 254 {
 255   return DATABASEP (object) ? 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 #if DB_VERSION_MAJOR > 2
 376     case DB_QUEUE: return Qqueue;
 377 #endif
 378     default:       return Qunknown;
 379     }
 380 }
 381
 382 static Lisp_Object
 383 berkdb_lasterr (Lisp_Database *db)
 384 {
 385   return lisp_strerror (db->dberrno);
 386 }
 387
 388 static Lisp_Object
 389 berkdb_get (Lisp_Database *db, Lisp_Object key)
 390 {
 391   DBT keydatum, valdatum;
 392   int status = 0;
 393
 394   /* DB Version 2 requires DBT's to be zeroed before use. */
 395   xzero (keydatum);
 396   xzero (valdatum);
 397
 398   keydatum.data = XSTRING_DATA (key);
 399   keydatum.size = XSTRING_LENGTH (key);
 400
 401 #if DB_VERSION_MAJOR == 1
 402   status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
 403 #else
 404   status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
 405 #endif /* DB_VERSION_MAJOR */
 406
 407   if (!status)
 408     /* #### Not mule-ized! will crash! */
 409     return make_string ((Bufbyte *) valdatum.data, valdatum.size);
 410
 411 #if DB_VERSION_MAJOR == 1
 412   db->dberrno = (status == 1) ? -1 : errno;
 413 #else
 414   db->dberrno = (status < 0) ? -1 : errno;
 415 #endif /* DB_VERSION_MAJOR */
 416
 417   return Qnil;
 418 }
 419
 420 static int
 421 berkdb_put (Lisp_Database *db,
 422             Lisp_Object key,
 423             Lisp_Object val,
 424             Lisp_Object replace)
 425 {
 426   DBT keydatum, valdatum;
 427   int status = 0;
 428
 429   /* DB Version 2 requires DBT's to be zeroed before use. */
 430   xzero (keydatum);
 431   xzero (valdatum);
 432
 433   keydatum.data = XSTRING_DATA   (key);
 434   keydatum.size = XSTRING_LENGTH (key);
 435   valdatum.data = XSTRING_DATA   (val);
 436   valdatum.size = XSTRING_LENGTH (val);
 437 #if DB_VERSION_MAJOR == 1
 438   status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
 439                                NILP (replace) ? R_NOOVERWRITE : 0);
 440   db->dberrno = (status == 1) ? -1 : errno;
 441 #else
 442   status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
 443                                NILP (replace) ? DB_NOOVERWRITE : 0);
 444   db->dberrno = (status < 0) ? -1 : errno;
 445 #endif/* DV_VERSION_MAJOR = 2 */
 446
 447   return status;
 448 }
 449
 450 static int
 451 berkdb_remove (Lisp_Database *db, Lisp_Object key)
 452 {
 453   DBT keydatum;
 454   int status;
 455
 456   /* DB Version 2 requires DBT's to be zeroed before use. */
 457   xzero (keydatum);
 458
 459   keydatum.data = XSTRING_DATA   (key);
 460   keydatum.size = XSTRING_LENGTH (key);
 461
 462 #if DB_VERSION_MAJOR == 1
 463   status = db->db_handle->del (db->db_handle, &keydatum, 0);
 464 #else
 465   status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
 466 #endif /* DB_VERSION_MAJOR */
 467
 468   if (!status)
 469     return 0;
 470
 471 #if DB_VERSION_MAJOR == 1
 472   db->dberrno = (status == 1) ? -1 : errno;
 473 #else
 474   db->dberrno = (status < 0) ? -1 : errno;
 475 #endif /* DB_VERSION_MAJOR */
 476
 477   return 1;
 478 }
 479
 480 static void
 481 berkdb_map (Lisp_Database *db, Lisp_Object func)
 482 {
 483   DBT keydatum, valdatum;
 484   Lisp_Object key, val;
 485   DB *dbp = db->db_handle;
 486   int status;
 487
 488   xzero (keydatum);
 489   xzero (valdatum);
 490
 491 #if DB_VERSION_MAJOR == 1
 492   for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
 493        status == 0;
 494        status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
 495     {
 496       /* #### Needs mule-izing */
 497       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 498       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 499       call2 (func, key, val);
 500     }
 501 #else
 502   {
 503     DBC *dbcp;
 504
 505 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
 506     status = dbp->cursor (dbp, NULL, &dbcp, 0);
 507 #else
 508     status = dbp->cursor (dbp, NULL, &dbcp);
 509 #endif
 510     for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
 511          status == 0;
 512          status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
 513       {
 514         /* #### Needs mule-izing */
 515         key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 516         val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 517         call2 (func, key, val);
 518       }
 519     dbcp->c_close (dbcp);
 520   }
 521 #endif /* DB_VERSION_MAJOR */
 522 }
 523
 524 static void
 525 berkdb_close (Lisp_Database *db)
 526 {
 527   if (db->db_handle)
 528     {
 529 #if DB_VERSION_MAJOR == 1
 530       db->db_handle->sync  (db->db_handle, 0);
 531       db->db_handle->close (db->db_handle);
 532 #else
 533       db->db_handle->sync  (db->db_handle, 0);
 534       db->db_handle->close (db->db_handle, 0);
 535 #endif /* DB_VERSION_MAJOR */
 536       db->db_handle = NULL;
 537     }
 538 }
 539
 540 static DB_FUNCS berk_func_block =
 541 {
 542   berkdb_subtype,
 543   berkdb_type,
 544   berkdb_get,
 545   berkdb_put,
 546   berkdb_remove,
 547   berkdb_map,
 548   berkdb_close,
 549   berkdb_lasterr
 550 };
 551 #endif /* HAVE_BERKELEY_DB */
 552
 553 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 554 Return the last error associated with DATABASE.
 555 */
 556        (database))
 557 {
 558   if (NILP (database))
 559     return lisp_strerror (errno);
 560
 561   CHECK_DATABASE (database);
 562
 563   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 564 }
 565
 566 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 567 Return a new database object opened on FILE.
 568 Optional arguments TYPE and SUBTYPE specify the database type.
 569 Optional argument ACCESS specifies the access rights, which may be any
 570 combination of 'r' 'w' and '+', for read, write, and creation flags.
 571 Optional argument MODE gives the permissions to use when opening FILE,
 572 and defaults to 0755.
 573 */
 574        (file, type, subtype, access_, mode))
 575 {
 576   /* This function can GC */
 577   int modemask;
 578   int accessmask = 0;
 579   Lisp_Database *db = NULL;
 580   char *filename;
 581   struct gcpro gcpro1, gcpro2;
 582
 583   CHECK_STRING (file);
 584   GCPRO2 (file, access_);
 585   file = Fexpand_file_name (file, Qnil);
 586   UNGCPRO;
 587
 588   TO_EXTERNAL_FORMAT (LISP_STRING, file,
 589                       C_STRING_ALLOCA, filename,
 590                       Qfile_name);
 591
 592   if (NILP (access_))
 593     {
 594       accessmask = O_RDWR | O_CREAT;
 595     }
 596   else
 597     {
 598       char *acc;
 599       CHECK_STRING (access_);
 600       acc = (char *) XSTRING_DATA (access_);
 601
 602       if (strchr (acc, '+'))
 603         accessmask |= O_CREAT;
 604
 605       {
 606         char *rp = strchr (acc, 'r');
 607         char *wp = strchr (acc, 'w');
 608         if (rp && wp) accessmask |= O_RDWR;
 609         else if (wp)  accessmask |= O_WRONLY;
 610         else          accessmask |= O_RDONLY;
 611       }
 612     }
 613
 614   if (NILP (mode))
 615     {
 616       modemask = 0755;          /* rwxr-xr-x */
 617     }
 618   else
 619     {
 620       CHECK_INT (mode);
 621       modemask = XINT (mode);
 622     }
 623
 624 #ifdef HAVE_DBM
 625   if (NILP (type) || EQ (type, Qdbm))
 626     {
 627       DBM *dbase = dbm_open (filename, accessmask, modemask);
 628       if (!dbase)
 629         return Qnil;
 630
 631       db = allocate_database ();
 632       db->dbm_handle = dbase;
 633       db->funcs = &ndbm_func_block;
 634       goto db_done;
 635     }
 636 #endif /* HAVE_DBM */
 637
 638 #ifdef HAVE_BERKELEY_DB
 639   if (NILP (type) || EQ (type, Qberkeley_db))
 640     {
 641       DBTYPE real_subtype;
 642       DB *dbase;
 643 #if DB_VERSION_MAJOR != 1
 644       int status;
 645 #endif
 646
 647       if (EQ (subtype, Qhash) || NILP (subtype))
 648         real_subtype = DB_HASH;
 649       else if (EQ (subtype, Qbtree))
 650         real_subtype = DB_BTREE;
 651       else if (EQ (subtype, Qrecno))
 652         real_subtype = DB_RECNO;
 653 #if DB_VERSION_MAJOR > 2
 654       else if (EQ (subtype, Qqueue))
 655         real_subtype = DB_QUEUE;
 656 #endif
 657       else
 658         signal_simple_error ("Unsupported subtype", subtype);
 659
 660 #if DB_VERSION_MAJOR == 1
 661       dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
 662       if (!dbase)
 663         return Qnil;
 664 #else
 665       /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 666          other flags shouldn't be set */
 667       if (NILP (access_))
 668         accessmask = DB_CREATE;
 669       else
 670         {
 671           char *acc;
 672           CHECK_STRING (access_);
 673           acc = (char *) XSTRING_DATA (access_);
 674           accessmask = 0;
 675
 676           if (strchr (acc, '+'))
 677             accessmask |= DB_CREATE;
 678
 679           if (strchr (acc, 'r') && !strchr (acc, 'w'))
 680             accessmask |= DB_RDONLY;
 681         }
 682 #if DB_VERSION_MAJOR == 2
 683       status = db_open (filename, real_subtype, accessmask,
 684                         modemask, NULL , NULL, &dbase);
 685       if (status)
 686         return Qnil;
 687 #else
 688       status = db_create (&dbase, NULL, 0);
 689       if (status)
 690         return Qnil;
 691       status = dbase->open (dbase, filename, NULL,
 692                             real_subtype, accessmask, modemask);
 693       if (status)
 694         {
 695           dbase->close (dbase, 0);
 696           return Qnil;
 697         }
 698 #endif /* DB_VERSION_MAJOR > 2 */
 699       /* Normalize into system specific file modes. Only for printing */
 700       accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
 701 #endif /* DB_VERSION_MAJOR */
 702
 703       db = allocate_database ();
 704       db->db_handle = dbase;
 705       db->funcs = &berk_func_block;
 706       goto db_done;
 707     }
 708 #endif /* HAVE_BERKELEY_DB */
 709
 710   signal_simple_error ("Unsupported database type", type);
 711   return Qnil;
 712
 713  db_done:
 714   db->live_p = 1;
 715   db->fname = file;
 716   db->mode = modemask;
 717   db->access_ = accessmask;
 718
 719   {
 720     Lisp_Object retval;
 721     XSETDATABASE (retval, db);
 722     return retval;
 723   }
 724 }
 725
 726 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
 727 Store KEY and VALUE in DATABASE.
 728 If optional fourth arg REPLACE is non-nil,
 729 replace any existing entry in the database.
 730 */
 731        (key, value, database, replace))
 732 {
 733   CHECK_LIVE_DATABASE (database);
 734   CHECK_STRING (key);
 735   CHECK_STRING (value);
 736   {
 737     Lisp_Database *db = XDATABASE (database);
 738     int status = db->funcs->put (db, key, value, replace);
 739     return status ? Qt : Qnil;
 740   }
 741 }
 742
 743 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
 744 Remove KEY from DATABASE.
 745 */
 746        (key, database))
 747 {
 748   CHECK_LIVE_DATABASE (database);
 749   CHECK_STRING (key);
 750   {
 751     Lisp_Database *db = XDATABASE (database);
 752     int status = db->funcs->rem (db, key);
 753     return status ? Qt : Qnil;
 754   }
 755 }
 756
 757 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
 758 Return value for KEY in DATABASE.
 759 If there is no corresponding value, return DEFAULT (defaults to nil).
 760 */
 761        (key, database, default_))
 762 {
 763   CHECK_LIVE_DATABASE (database);
 764   CHECK_STRING (key);
 765   {
 766     Lisp_Database *db = XDATABASE (database);
 767     Lisp_Object retval = db->funcs->get (db, key);
 768     return NILP (retval) ? default_ : retval;
 769   }
 770 }
 771
 772 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
 773 Map FUNCTION over entries in DATABASE, calling it with two args,
 774 each key and value in the database.
 775 */
 776        (function, database))
 777 {
 778   CHECK_LIVE_DATABASE (database);
 779
 780   XDATABASE (database)->funcs->map (XDATABASE (database), function);
 781
 782   return Qnil;
 783 }
 784
 785 void
 786 syms_of_database (void)
 787 {
 788   INIT_LRECORD_IMPLEMENTATION (database);
 789
 790   defsymbol (&Qdatabasep, "databasep");
 791 #ifdef HAVE_DBM
 792   defsymbol (&Qdbm, "dbm");
 793 #endif
 794 #ifdef HAVE_BERKELEY_DB
 795   defsymbol (&Qberkeley_db, "berkeley-db");
 796   defsymbol (&Qhash, "hash");
 797   defsymbol (&Qbtree, "btree");
 798   defsymbol (&Qrecno, "recno");
 799 #if DB_VERSION_MAJOR > 2
 800   defsymbol (&Qqueue, "queue");
 801 #endif
 802   defsymbol (&Qunknown, "unknown");
 803 #endif
 804
 805   DEFSUBR (Fopen_database);
 806   DEFSUBR (Fdatabasep);
 807   DEFSUBR (Fmapdatabase);
 808   DEFSUBR (Fput_database);
 809   DEFSUBR (Fget_database);
 810   DEFSUBR (Fremove_database);
 811   DEFSUBR (Fdatabase_type);
 812   DEFSUBR (Fdatabase_subtype);
 813   DEFSUBR (Fdatabase_last_error);
 814   DEFSUBR (Fdatabase_live_p);
 815   DEFSUBR (Fdatabase_file_name);
 816   DEFSUBR (Fclose_database);
 817 }
 818
 819 void
 820 vars_of_database (void)
 821 {
 822 #ifdef HAVE_DBM
 823   Fprovide (Qdbm);
 824 #endif
 825 #ifdef HAVE_BERKELEY_DB
 826   Fprovide (Qberkeley_db);
 827 #endif
 828
 829 #if 0 /* #### implement me! */
 830 #ifdef MULE
 831   DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
 832 Coding system used to convert data in database files.
 833 */ );
 834   Vdatabase_coding_system = Qnil;
 835 #endif
 836 #endif /* 0 */
 837 }