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   {
 502     DBC *dbcp;
 503
 504     status = dbp->cursor (dbp, NULL, &dbcp);
 505     for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
 506          status == 0;
 507          status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
 508       {
 509         /* ### Needs mule-izing */
 510         key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
 511         val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
 512         call2 (func, key, val);
 513       }
 514     dbcp->c_close (dbcp);
 515   }
 516 #endif /* DB_VERSION_MAJOR */
 517 }
 518
 519 static void
 520 berkdb_close (Lisp_Database *db)
 521 {
 522   if (db->db_handle)
 523     {
 524 #if DB_VERSION_MAJOR == 1
 525       db->db_handle->sync  (db->db_handle, 0);
 526       db->db_handle->close (db->db_handle);
 527 #else
 528       db->db_handle->sync  (db->db_handle, 0);
 529       db->db_handle->close (db->db_handle, 0);
 530 #endif /* DB_VERSION_MAJOR */
 531       db->db_handle = NULL;
 532     }
 533 }
 534
 535 static DB_FUNCS berk_func_block =
 536 {
 537   berkdb_subtype,
 538   berkdb_type,
 539   berkdb_get,
 540   berkdb_put,
 541   berkdb_remove,
 542   berkdb_map,
 543   berkdb_close,
 544   berkdb_lasterr
 545 };
 546 #endif /* HAVE_BERKELEY_DB */
 547
 548 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
 549 Return the last error associated with DATABASE.
 550 */
 551        (database))
 552 {
 553   if (NILP (database))
 554     return lisp_strerror (errno);
 555
 556   CHECK_DATABASE (database);
 557
 558   return XDATABASE (database)->funcs->last_error (XDATABASE (database));
 559 }
 560
 561 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
 562 Return a new database object opened on FILE.
 563 Optional arguments TYPE and SUBTYPE specify the database type.
 564 Optional argument ACCESS specifies the access rights, which may be any
 565 combination of 'r' 'w' and '+', for read, write, and creation flags.
 566 Optional argument MODE gives the permissions to use when opening FILE,
 567 and defaults to 0755.
 568 */
 569        (file, type, subtype, access_, mode))
 570 {
 571   /* This function can GC */
 572   int modemask;
 573   int accessmask = 0;
 574   Lisp_Database *db = NULL;
 575   char *filename;
 576   struct gcpro gcpro1, gcpro2;
 577
 578   CHECK_STRING (file);
 579   GCPRO2 (file, access_);
 580   file = Fexpand_file_name (file, Qnil);
 581   UNGCPRO;
 582
 583   GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
 584
 585   if (NILP (access_))
 586     {
 587       accessmask = O_RDWR | O_CREAT;
 588     }
 589   else
 590     {
 591       char *acc;
 592       CHECK_STRING (access_);
 593       acc = (char *) XSTRING_DATA (access_);
 594
 595       if (strchr (acc, '+'))
 596         accessmask |= O_CREAT;
 597
 598       {
 599         char *rp = strchr (acc, 'r');
 600         char *wp = strchr (acc, 'w');
 601         if (rp && wp) accessmask |= O_RDWR;
 602         else if (wp)  accessmask |= O_WRONLY;
 603         else          accessmask |= O_RDONLY;
 604       }
 605     }
 606
 607   if (NILP (mode))
 608     {
 609       modemask = 0755;          /* rwxr-xr-x */
 610     }
 611   else
 612     {
 613       CHECK_INT (mode);
 614       modemask = XINT (mode);
 615     }
 616
 617 #ifdef HAVE_DBM
 618   if (NILP (type) || EQ (type, Qdbm))
 619     {
 620       DBM *dbase = dbm_open (filename, accessmask, modemask);
 621       if (!dbase)
 622         return Qnil;
 623
 624       db = allocate_database ();
 625       db->dbm_handle = dbase;
 626       db->funcs = &ndbm_func_block;
 627       goto db_done;
 628     }
 629 #endif /* HAVE_DBM */
 630
 631 #ifdef HAVE_BERKELEY_DB
 632   if (NILP (type) || EQ (type, Qberkeley_db))
 633     {
 634       DBTYPE real_subtype;
 635       DB *dbase;
 636 #if DB_VERSION_MAJOR != 1
 637       int status;
 638 #endif
 639
 640       if (EQ (subtype, Qhash) || NILP (subtype))
 641         real_subtype = DB_HASH;
 642       else if (EQ (subtype, Qbtree))
 643         real_subtype = DB_BTREE;
 644       else if (EQ (subtype, Qrecno))
 645         real_subtype = DB_RECNO;
 646       else
 647         signal_simple_error ("Unsupported subtype", subtype);
 648
 649 #if DB_VERSION_MAJOR == 1
 650       dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
 651       if (!dbase)
 652         return Qnil;
 653 #else
 654       /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
 655          other flags shouldn't be set */
 656       if (NILP (access_))
 657         accessmask = DB_CREATE;
 658       else
 659         {
 660           char *acc;
 661           CHECK_STRING (access_);
 662           acc = (char *) XSTRING_DATA (access_);
 663           accessmask = 0;
 664
 665           if (strchr (acc, '+'))
 666             accessmask |= DB_CREATE;
 667
 668           if (strchr (acc, 'r') && !strchr (acc, 'w'))
 669             accessmask |= DB_RDONLY;
 670         }
 671       status = db_open (filename, real_subtype, accessmask,
 672                         modemask, NULL , NULL, &dbase);
 673       if (status)
 674         return Qnil;
 675 #endif /* DB_VERSION_MAJOR */
 676
 677       db = allocate_database ();
 678       db->db_handle = dbase;
 679       db->funcs = &berk_func_block;
 680       goto db_done;
 681     }
 682 #endif /* HAVE_BERKELEY_DB */
 683
 684   signal_simple_error ("Unsupported database type", type);
 685   return Qnil;
 686
 687  db_done:
 688   db->live_p = 1;
 689   db->fname = file;
 690   db->mode = modemask;
 691   db->access_ = accessmask;
 692
 693   {
 694     Lisp_Object retval;
 695     XSETDATABASE (retval, db);
 696     return retval;
 697   }
 698 }
 699
 700 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
 701 Store KEY and VALUE in DATABASE.
 702 If optional fourth arg REPLACE is non-nil,
 703 replace any existing entry in the database.
 704 */
 705        (key, value, database, replace))
 706 {
 707   CHECK_LIVE_DATABASE (database);
 708   CHECK_STRING (key);
 709   CHECK_STRING (value);
 710   {
 711     Lisp_Database *db = XDATABASE (database);
 712     int status = db->funcs->put (db, key, value, replace);
 713     return status ? Qt : Qnil;
 714   }
 715 }
 716
 717 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
 718 Remove KEY from DATABASE.
 719 */
 720        (key, database))
 721 {
 722   CHECK_LIVE_DATABASE (database);
 723   CHECK_STRING (key);
 724   {
 725     Lisp_Database *db = XDATABASE (database);
 726     int status = db->funcs->rem (db, key);
 727     return status ? Qt : Qnil;
 728   }
 729 }
 730
 731 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
 732 Return value for KEY in DATABASE.
 733 If there is no corresponding value, return DEFAULT (defaults to nil).
 734 */
 735        (key, database, default_))
 736 {
 737   CHECK_LIVE_DATABASE (database);
 738   CHECK_STRING (key);
 739   {
 740     Lisp_Database *db = XDATABASE (database);
 741     Lisp_Object retval = db->funcs->get (db, key);
 742     return NILP (retval) ? default_ : retval;
 743   }
 744 }
 745
 746 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
 747 Map FUNCTION over entries in DATABASE, calling it with two args,
 748 each key and value in the database.
 749 */
 750        (function, database))
 751 {
 752   CHECK_LIVE_DATABASE (database);
 753
 754   XDATABASE (database)->funcs->map (XDATABASE (database), function);
 755
 756   return Qnil;
 757 }
 758
 759 void
 760 syms_of_database (void)
 761 {
 762   defsymbol (&Qdatabasep, "databasep");
 763 #ifdef HAVE_DBM
 764   defsymbol (&Qdbm, "dbm");
 765 #endif
 766 #ifdef HAVE_BERKELEY_DB
 767   defsymbol (&Qberkeley_db, "berkeley-db");
 768   defsymbol (&Qhash, "hash");
 769   defsymbol (&Qbtree, "btree");
 770   defsymbol (&Qrecno, "recno");
 771   defsymbol (&Qunknown, "unknown");
 772 #endif
 773
 774   DEFSUBR (Fopen_database);
 775   DEFSUBR (Fdatabasep);
 776   DEFSUBR (Fmapdatabase);
 777   DEFSUBR (Fput_database);
 778   DEFSUBR (Fget_database);
 779   DEFSUBR (Fremove_database);
 780   DEFSUBR (Fdatabase_type);
 781   DEFSUBR (Fdatabase_subtype);
 782   DEFSUBR (Fdatabase_last_error);
 783   DEFSUBR (Fdatabase_live_p);
 784   DEFSUBR (Fdatabase_file_name);
 785   DEFSUBR (Fclose_database);
 786 }
 787
 788 void
 789 vars_of_database (void)
 790 {
 791 #ifdef HAVE_DBM
 792   Fprovide (Qdbm);
 793 #endif
 794 #ifdef HAVE_BERKELEY_DB
 795   Fprovide (Qberkeley_db);
 796 #endif
 797
 798 #if 0 /* #### implement me! */
 799 #ifdef MULE
 800   DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
 801 Coding system used to convert data in database files.
 802 */ );
 803   Vdatabase_coding_system = Qnil;
 804 #endif
 805 #endif /* 0 */
 806 }