git.chise.org Git - chise/xemacs-chise.git.1/blob - src/database.c

   1 /* Database access routines
   2    Copyright (C) 1996, William M. Perry
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Not in FSF. */
  22
  23 /* Written by Bill Perry */
  24 /* Substantially rewritten by Martin Buchholz */
  25 /* db 2.x support added by Andreas Jaeger */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29 #include "sysfile.h"
  30 #include "buffer.h"
  31 #include <errno.h>
  32
  33 #ifndef HAVE_DATABASE
  34 #error HAVE_DATABASE not defined!!
  35 #endif
  36
  37 #include "database.h"         /* Our include file */
  38
  39 #ifdef HAVE_BERKELEY_DB
  40 /* Work around Berkeley DB's use of int types which are defined
  41    slightly differently in the not quite yet standard <inttypes.h>.
  42    See db.h for details of why we're resorting to this... */
  43 /* glibc 2.1 doesn't have this problem with DB 2.x */
  44 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1)
  45 #ifdef HAVE_INTTYPES_H
  46 #define __BIT_TYPES_DEFINED__
  47 #include <inttypes.h>
  48 typedef uint8_t  u_int8_t;
  49 typedef uint16_t u_int16_t;
  50 typedef uint32_t u_int32_t;
  51 #ifdef WE_DONT_NEED_QUADS
  52 typedef uint64_t u_int64_t;
  53 #endif /* WE_DONT_NEED_QUADS */
  54 #endif /* HAVE_INTTYPES_H */
  55 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */
  56 #include DB_H_PATH              /* Berkeley db's header file */
  57 #ifndef DB_VERSION_MAJOR
  58 # define DB_VERSION_MAJOR 1
  59 #endif /* DB_VERSION_MAJOR */
  60 Lisp_Object Qberkeley_db;
  61 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
  62 #endif /* HAVE_BERKELEY_DB */
  63
  64 #ifdef HAVE_DBM
  65 #include <ndbm.h>
  66 Lisp_Object Qdbm;
  67 #endif /* HAVE_DBM */
  68
  69 #ifdef MULE
  70 /* #### The following should be settable on a per-database level.
  71    But the whole coding-system infrastructure should be rewritten someday.
  72    We really need coding-system aliases. -- martin */
  73 Lisp_Object Vdatabase_coding_system;
  74 #endif
  75
  76 Lisp_Object Qdatabasep;
  77
  78 struct Lisp_Database;
  79 typedef struct Lisp_Database Lisp_Database;
  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 GC_DATABASEP(x) GC_RECORDP (x, database)
 117 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
 118 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
 119 #define DATABASE_LIVE_P(x) (x->live_p)
 120
 121 #define CHECK_LIVE_DATABASE(db) do {                                    \
 122   CHECK_DATABASE (db);                                                  \
 123   if (!DATABASE_LIVE_P (XDATABASE(db)))                                 \
 124     signal_simple_error ("Attempting to access closed database", db);   \
 125 } while (0)
 126
 127
 128 static Lisp_Database *
 129 allocate_database (void)
 130 {
 131   Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, lrecord_database);
 132
 133   db->fname = Qnil;
 134   db->live_p = 0;
 135 #ifdef HAVE_BERKELEY_DB
 136   db->db_handle = NULL;
 137 #endif
 138 #ifdef HAVE_DBM
 139   db->dbm_handle = NULL;
 140 #endif
 141   db->access_ = 0;
 142   db->mode = 0;
 143   db->dberrno = 0;
 144 #ifdef MULE
 145   db->coding_system = Fget_coding_system (Qbinary);
 146 #endif
 147   return db;
 148 }
 149
 150 static Lisp_Object
 151 mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object))
 152 {
 153   Lisp_Database *db = XDATABASE (obj);
 154
 155   markobj (db->fname);
 156   return Qnil;
 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 obj;
 188       XSETDATABASE (obj, db);
 189
 190       signal_simple_error
 191         ("Can't dump an emacs containing database objects", obj);
 192     }
 193   db->funcs->close (db);
 194 }
 195
 196 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
 197                                mark_database, print_database,
 198                                finalize_database, 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 OBJ is an active database.
 236 */
 237        (obj))
 238 {
 239   return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
 240 }
 241
 242 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
 243 Return the filename associated with the database DATABASE.
 244 */
 245        (database))
 246 {
 247   CHECK_DATABASE (database);
 248
 249   return XDATABASE (database)->fname;
 250 }
 251
 252 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
 253 Return t if OBJ is a database.
 254 */
 255        (obj))
 256 {
 257   return DATABASEP (obj) ? Qt : Qnil;
 258 }
 259
 260 #ifdef HAVE_DBM
 261 static void
 262 dbm_map (Lisp_Database *db, Lisp_Object func)
 263 {
 264   datum keydatum, valdatum;
 265   Lisp_Object key, val;
 266
 267   for (keydatum = dbm_firstkey (db->dbm_handle);
 268        keydatum.dptr != NULL;
 269        keydatum = dbm_nextkey (db->dbm_handle))
 270     {
 271       valdatum = dbm_fetch (db->dbm_handle, keydatum);
 272       key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
 273       val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
 274       call2 (func, key, val);
 275     }
 276 }
 277
 278 static Lisp_Object
 279 dbm_get (Lisp_Database *db, Lisp_Object key)
 280 {
 281   datum keydatum, valdatum;
 282
 283   keydatum.dptr = (char *) XSTRING_DATA (key);
 284   keydatum.dsize = XSTRING_LENGTH (key);
 285   valdatum = dbm_fetch (db->dbm_handle, keydatum);
 286
 287   return (valdatum.dptr
 288           ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
 289           : Qnil);
 290 }
 291
 292 static int
 293 dbm_put (Lisp_Database *db,
 294          Lisp_Object key, Lisp_Object val, Lisp_Object replace)
 295 {
 296   datum keydatum, valdatum;
 297
 298   valdatum.dptr = (char *) XSTRING_DATA (val);
 299   valdatum.dsize = XSTRING_LENGTH (val);
 300   keydatum.dptr = (char *) XSTRING_DATA (key);
 301   keydatum.dsize = XSTRING_LENGTH (key);
 302
 303   return !dbm_store (db->dbm_handle, keydatum, valdatum,
 304                      NILP (replace) ? DBM_INSERT : DBM_REPLACE);
 305 }
 306
 307 static int
 308 dbm_remove (Lisp_Database *db, Lisp_Object key)
 309 {
 310   datum keydatum;
 311
 312   keydatum.dptr = (char *) XSTRING_DATA (key);
 313   keydatum.dsize = XSTRING_LENGTH (key);
 314
 315   return dbm_delete (db->dbm_handle, keydatum);
 316 }
 317
 318 static Lisp_Object
 319 dbm_type (Lisp_Database *db)
 320 {
 321   return Qdbm;
 322 }
 323
 324 static Lisp_Object
 325 dbm_subtype (Lisp_Database *db)
 326 {
 327   return Qnil;
 328 }
 329
 330 static Lisp_Object
 331 dbm_lasterr (Lisp_Database *db)
 332 {
 333   return lisp_strerror (db->dberrno);
 334 }
 335
 336 static void
 337 dbm_closeit (Lisp_Database *db)
 338 {
 339   if (db->dbm_handle)
 340     {
 341       dbm_close (db->dbm_handle);
 342       db->dbm_handle = NULL;
 343     }
 344 }
 345
 346 static DB_FUNCS ndbm_func_block =
 347 {
 348   dbm_subtype,
 349   dbm_type,
 350   dbm_get,
 351   dbm_put,
 352   dbm_remove,
 353   dbm_map,
 354   dbm_closeit,
 355   dbm_lasterr
 356 };
 357 #endif /* HAVE_DBM */
 358
 359 #ifdef HAVE_BERKELEY_DB
 360 static Lisp_Object
 361 berkdb_type (Lisp_Database *db)
 362 {
 363   return Qberkeley_db;
 364 }
 365
 366 static Lisp_Object
 367 berkdb_subtype (Lisp_Database *db)
 368 {
 369   if (!db->db_handle)
 370     return Qnil;
 371
 372   switch (db->db_handle->type)
 373     {
 374     case DB_BTREE: return Qbtree;
 375     case DB_HASH:  return Qhash;
 376     case DB_RECNO: return Qrecno;
 377     default:       return Qunknown;
 378     }
 379 }
 380
 381 static Lisp_Object
 382 berkdb_lasterr (Lisp_Database *db)
 383 {
 384   return lisp_strerror (db->dberrno);
 385 }
 386
 387 static Lisp_Object
 388 berkdb_get (Lisp_Database *db, Lisp_Object key)
 389 {
 390   DBT keydatum, valdatum;
 391   int status = 0;
 392
 393   /* DB Version 2 requires DBT's to be zeroed before use. */
 394   xzero (keydatum);
 395   xzero (valdatum);
 396
 397   keydatum.data = XSTRING_DATA (key);
 398   keydatum.size = XSTRING_LENGTH (key);
 399
 400 #if DB_VERSION_MAJOR == 1
 401   status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
 402 #else
 403   status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
 404 #endif /* DB_VERSION_MAJOR */
 405
 406   if (!status)
 407     /* #### Not mule-ized! will crash! */
 408     return make_string ((Bufbyte *) valdatum.data, valdatum.size);
 409
 410 #if DB_VERSION_MAJOR == 1
 411   db->dberrno = (status == 1) ? -1 : errno;
 412 #else
 413   db->dberrno = (status < 0) ? -1 : errno;
 414 #endif /* DB_VERSION_MAJOR */
 415
 416   return Qnil;
 417 }
 418
 419 static int
 420 berkdb_put (Lisp_Database *db,
 421             Lisp_Object key,
 422             Lisp_Object val,
 423             Lisp_Object replace)
 424 {
 425   DBT keydatum, valdatum;
 426   int status = 0;
 427
 428   /* DB Version 2 requires DBT's to be zeroed before use. */
 429   xzero (keydatum);
 430   xzero (valdatum);
 431
 432   keydatum.data = XSTRING_DATA   (key);
 433   keydatum.size = XSTRING_LENGTH (key);
 434   valdatum.data = XSTRING_DATA   (val);
 435   valdatum.size = XSTRING_LENGTH (val);
 436 #if DB_VERSION_MAJOR == 1
 437   status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
 438                                NILP (replace) ? R_NOOVERWRITE : 0);
 439   db->dberrno = (status == 1) ? -1 : errno;
 440 #else
 441   status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
 442                                NILP (replace) ? DB_NOOVERWRITE : 0);
 443   db->dberrno = (status < 0) ? -1 : errno;
 444 #endif/* DV_VERSION_MAJOR = 2 */
 445
 446   return status;
 447 }
 448
 449 static int
 450 berkdb_remove (Lisp_Database *db, Lisp_Object key)
 451 {
 452   DBT keydatum;
 453   int status;
 454
 455   /* DB Version 2 requires DBT's to be zeroed before use. */
 456   xzero (keydatum);
 457
 458   keydatum.data = XSTRING_DATA   (key);
 459   keydatum.size = XSTRING_LENGTH (key);
 460
 461 #if DB_VERSION_MAJOR == 1
 462   status = db->db_handle->del (db->db_handle, &keydatum, 0);
 463 #else
 464   status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
 465 #endif /* DB_VERSION_MAJOR */
 466
 467   if (!status)
 468     return 0;
 469
 470 #if DB_VERSION_MAJOR == 1
 471   db->dberrno = (status == 1) ? -1 : errno;
 472 #else
 473   db->dberrno = (status < 0) ? -1 : errno;
 474 #endif /* DB_VERSION_MAJOR */
 475
 476   return 1;
 477 }
 478
 479 static void
 480 berkdb_map (Lisp_Database *db, Lisp_Object func)
 481 {
 482   DBT keydatum, valdatum;
 483   Lisp_Object key, val;
 484   DB *dbp = db->db_handle;
 485   int status;
 486
 487   xzero (keydatum);
 488   xzero (valdatum);
 489
 490 #if DB_VERSION_MAJOR == 1
 491   for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
 492        status == 0;
 493        status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
 494     {
 495       /* ### Needs mule-izing */
 496       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 497       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 498       call2 (func, key, val);
 499     }
 500 #else
 501   DBC *dbcp;
 502
 503   status = dbp->cursor (dbp, NULL, &dbcp);
 504   for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
 505        status == 0;
 506        status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
 507     {
 508       /* ### Needs mule-izing */
 509       key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 510       val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 511       call2 (func, key, val);
 512     }
 513   dbcp->c_close (dbcp);
 514 #endif /* DB_VERSION_MAJOR */
 515 }
 516
 517 static void
 518 berkdb_close (Lisp_Database *db)
 519 {
 520   if (db->db_handle)
 521     {
 522 #if DB_VERSION_MAJOR == 1
 523       db->db_handle->sync  (db->db_handle, 0);
 524       db->db_handle->close (db->db_handle);
 525 #else
 526       db->db_handle->sync  (db->db_handle, 0);
 527       db->db_handle->close (db->db_handle, 0);
 528 #endif /* DB_VERSION_MAJOR */
 529       db->db_handle = NULL;
 530     }
 531 }
 532
 533 static DB_FUNCS berk_func_block =
 534 {
 535   berkdb_subtype,
 536   berkdb_type,
 537   berkdb_get,
 538   berkdb_put,
 539   berkdb_remove,
 540   berkdb_map,
 541   berkdb_close,
 542   berkdb_lasterr
 543 };
 544 #endif /* HAVE_BERKELEY_DB */
 545
 546 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 547 Return the last error associated with DATABASE.
 548 */
 549        (database))
 550 {
 551   if (NILP (database))
 552     return lisp_strerror (errno);
 553
 554   CHECK_DATABASE (database);
 555
 556   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 557 }
 558
 559 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 560 Return a new database object opened on FILE.
 561 Optional arguments TYPE and SUBTYPE specify the database type.
 562 Optional argument ACCESS specifies the access rights, which may be any
 563 combination of 'r' 'w' and '+', for read, write, and creation flags.
 564 Optional argument MODE gives the permissions to use when opening FILE,
 565 and defaults to 0755.
 566 */
 567        (file, type, subtype, access_, mode))
 568 {
 569   /* This function can GC */
 570   int modemask;
 571   int accessmask = 0;
 572   Lisp_Database *db = NULL;
 573   char *filename;
 574   struct gcpro gcpro1, gcpro2;
 575
 576   CHECK_STRING (file);
 577   GCPRO2 (file, access_);
 578   file = Fexpand_file_name (file, Qnil);
 579   UNGCPRO;
 580
 581   GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
 582
 583   if (NILP (access_))
 584     {
 585       accessmask = O_RDWR | O_CREAT;
 586     }
 587   else
 588     {
 589       char *acc;
 590       CHECK_STRING (access_);
 591       acc = (char *) XSTRING_DATA (access_);
 592
 593       if (strchr (acc, '+'))
 594         accessmask |= O_CREAT;
 595
 596       {
 597         char *rp = strchr (acc, 'r');
 598         char *wp = strchr (acc, 'w');
 599         if (rp && wp) accessmask |= O_RDWR;
 600         else if (wp)  accessmask |= O_WRONLY;
 601         else          accessmask |= O_RDONLY;
 602       }
 603     }
 604
 605   if (NILP (mode))
 606     {
 607       modemask = 0755;          /* rwxr-xr-x */
 608     }
 609   else
 610     {
 611       CHECK_INT (mode);
 612       modemask = XINT (mode);
 613     }
 614
 615 #ifdef HAVE_DBM
 616   if (NILP (type) || EQ (type, Qdbm))
 617     {
 618       DBM *dbase = dbm_open (filename, accessmask, modemask);
 619       if (!dbase)
 620         return Qnil;
 621
 622       db = allocate_database ();
 623       db->dbm_handle = dbase;
 624       db->funcs = &ndbm_func_block;
 625       goto db_done;
 626     }
 627 #endif /* HAVE_DBM */
 628
 629 #ifdef HAVE_BERKELEY_DB
 630   if (NILP (type) || EQ (type, Qberkeley_db))
 631     {
 632       DBTYPE real_subtype;
 633       DB *dbase;
 634 #if DB_VERSION_MAJOR != 1
 635       int status;
 636 #endif
 637
 638       if (EQ (subtype, Qhash) || NILP (subtype))
 639         real_subtype = DB_HASH;
 640       else if (EQ (subtype, Qbtree))
 641         real_subtype = DB_BTREE;
 642       else if (EQ (subtype, Qrecno))
 643         real_subtype = DB_RECNO;
 644       else
 645         signal_simple_error ("Unsupported subtype", subtype);
 646
 647 #if DB_VERSION_MAJOR == 1
 648       dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
 649       if (!dbase)
 650         return Qnil;
 651 #else
 652       /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 653          other flags shouldn't be set */
 654       if (NILP (access_))
 655         accessmask = DB_CREATE;
 656       else
 657         {
 658           char *acc;
 659           CHECK_STRING (access_);
 660           acc = (char *) XSTRING_DATA (access_);
 661           accessmask = 0;
 662
 663           if (strchr (acc, '+'))
 664             accessmask |= DB_CREATE;
 665
 666           if (strchr (acc, 'r') && !strchr (acc, 'w'))
 667             accessmask |= DB_RDONLY;
 668         }
 669       status = db_open (filename, real_subtype, accessmask,
 670                         modemask, NULL , NULL, &dbase);
 671       if (status)
 672         return Qnil;
 673 #endif /* DB_VERSION_MAJOR */
 674
 675       db = allocate_database ();
 676       db->db_handle = dbase;
 677       db->funcs = &berk_func_block;
 678       goto db_done;
 679     }
 680 #endif /* HAVE_BERKELEY_DB */
 681
 682   signal_simple_error ("Unsupported database type", type);
 683   return Qnil;
 684
 685  db_done:
 686   db->live_p = 1;
 687   db->fname = file;
 688   db->mode = modemask;
 689   db->access_ = accessmask;
 690
 691   {
 692     Lisp_Object retval;
 693     XSETDATABASE (retval, db);
 694     return retval;
 695   }
 696 }
 697
 698 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
 699 Store KEY and VALUE in DATABASE.
 700 If optional fourth arg REPLACE is non-nil,
 701 replace any existing entry in the database.
 702 */
 703        (key, value, database, replace))
 704 {
 705   CHECK_LIVE_DATABASE (database);
 706   CHECK_STRING (key);
 707   CHECK_STRING (value);
 708   {
 709     Lisp_Database *db = XDATABASE (database);
 710     int status = db->funcs->put (db, key, value, replace);
 711     return status ? Qt : Qnil;
 712   }
 713 }
 714
 715 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
 716 Remove KEY from DATABASE.
 717 */
 718        (key, database))
 719 {
 720   CHECK_LIVE_DATABASE (database);
 721   CHECK_STRING (key);
 722   {
 723     Lisp_Database *db = XDATABASE (database);
 724     int status = db->funcs->rem (db, key);
 725     return status ? Qt : Qnil;
 726   }
 727 }
 728
 729 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
 730 Return value for KEY in DATABASE.
 731 If there is no corresponding value, return DEFAULT (defaults to nil).
 732 */
 733        (key, database, default_))
 734 {
 735   CHECK_LIVE_DATABASE (database);
 736   CHECK_STRING (key);
 737   {
 738     Lisp_Database *db = XDATABASE (database);
 739     Lisp_Object retval = db->funcs->get (db, key);
 740     return NILP (retval) ? default_ : retval;
 741   }
 742 }
 743
 744 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
 745 Map FUNCTION over entries in DATABASE, calling it with two args,
 746 each key and value in the database.
 747 */
 748        (function, database))
 749 {
 750   CHECK_LIVE_DATABASE (database);
 751
 752   XDATABASE (database)->funcs->map (XDATABASE (database), function);
 753
 754   return Qnil;
 755 }
 756
 757 void
 758 syms_of_database (void)
 759 {
 760   defsymbol (&Qdatabasep, "databasep");
 761 #ifdef HAVE_DBM
 762   defsymbol (&Qdbm, "dbm");
 763 #endif
 764 #ifdef HAVE_BERKELEY_DB
 765   defsymbol (&Qberkeley_db, "berkeley-db");
 766   defsymbol (&Qhash, "hash");
 767   defsymbol (&Qbtree, "btree");
 768   defsymbol (&Qrecno, "recno");
 769   defsymbol (&Qunknown, "unknown");
 770 #endif
 771
 772   DEFSUBR (Fopen_database);
 773   DEFSUBR (Fdatabasep);
 774   DEFSUBR (Fmapdatabase);
 775   DEFSUBR (Fput_database);
 776   DEFSUBR (Fget_database);
 777   DEFSUBR (Fremove_database);
 778   DEFSUBR (Fdatabase_type);
 779   DEFSUBR (Fdatabase_subtype);
 780   DEFSUBR (Fdatabase_last_error);
 781   DEFSUBR (Fdatabase_live_p);
 782   DEFSUBR (Fdatabase_file_name);
 783   DEFSUBR (Fclose_database);
 784 }
 785
 786 void
 787 vars_of_database (void)
 788 {
 789 #ifdef HAVE_DBM
 790   Fprovide (Qdbm);
 791 #endif
 792 #ifdef HAVE_BERKELEY_DB
 793   Fprovide (Qberkeley_db);
 794 #endif
 795
 796 #if 0 /* #### implement me! */
 797 #ifdef MULE
 798   DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
 799 Coding system used to convert data in database files.
 800 */ );
 801   Vdatabase_coding_system = Qnil;
 802 #endif
 803 #endif /* 0 */
 804 }