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