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