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