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