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