1 /* Database access routines
2 Copyright (C) 1996, William M. Perry
4 This file is part of XEmacs.
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
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
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. */
21 /* Synched up with: Not in FSF. */
23 /* Written by Bill Perry */
24 /* Substantially rewritten by Martin Buchholz */
25 /* db 2.x support added by Andreas Jaeger */
33 #error HAVE_DATABASE not defined!!
36 #include "database.h" /* Our include file */
38 #ifdef HAVE_BERKELEY_DB
39 /* Work around Berkeley DB's use of int types which are defined
40 slightly differently in the not quite yet standard <inttypes.h>.
41 See db.h for details of why we're resorting to this... */
42 /* glibc 2.1 doesn't have this problem with DB 2.x */
43 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1)
44 #ifdef HAVE_INTTYPES_H
45 #define __BIT_TYPES_DEFINED__
47 typedef uint8_t u_int8_t;
48 typedef uint16_t u_int16_t;
49 typedef uint32_t u_int32_t;
50 #ifdef WE_DONT_NEED_QUADS
51 typedef uint64_t u_int64_t;
52 #endif /* WE_DONT_NEED_QUADS */
53 #endif /* HAVE_INTTYPES_H */
54 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */
55 #include DB_H_PATH /* Berkeley db's header file */
56 #ifndef DB_VERSION_MAJOR
57 # define DB_VERSION_MAJOR 1
58 #endif /* DB_VERSION_MAJOR */
59 Lisp_Object Qberkeley_db;
60 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
61 #endif /* HAVE_BERKELEY_DB */
68 Lisp_Object Qdatabasep;
70 typedef enum { DB_DBM, DB_BERKELEY, DB_IS_UNKNOWN } XEMACS_DB_TYPE;
76 Lisp_Object (*get_subtype) (struct Lisp_Database *);
77 Lisp_Object (*get_type) (struct Lisp_Database *);
78 Lisp_Object (*get) (struct Lisp_Database *, Lisp_Object);
79 int (*put) (struct Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
80 int (*rem) (struct Lisp_Database *, Lisp_Object);
81 void (*map) (struct Lisp_Database *, Lisp_Object);
82 void (*close) (struct Lisp_Database *);
83 Lisp_Object (*last_error) (struct Lisp_Database *);
88 struct lcrecord_header header;
98 #ifdef HAVE_BERKELEY_DB
103 Lisp_Object coding_system;
107 #define XDATABASE(x) XRECORD (x, database, struct Lisp_Database)
108 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
109 #define DATABASEP(x) RECORDP (x, database)
110 #define GC_DATABASEP(x) GC_RECORDP (x, database)
111 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
112 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
113 #define DATABASE_LIVE_P(x) (x->live_p)
115 #define CHECK_LIVE_DATABASE(db) do { \
116 CHECK_DATABASE (db); \
117 if (!DATABASE_LIVE_P (XDATABASE(db))) \
118 signal_simple_error ("Attempting to access closed database", db); \
122 static struct Lisp_Database *
123 allocate_database (void)
125 struct Lisp_Database *db =
126 alloc_lcrecord_type (struct Lisp_Database, lrecord_database);
130 #ifdef HAVE_BERKELEY_DB
131 db->db_handle = NULL;
134 db->dbm_handle = NULL;
139 db->type = DB_IS_UNKNOWN;
141 db->coding_system = Fget_coding_system (Qbinary);
147 mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object))
149 struct Lisp_Database *db = XDATABASE (obj);
151 ((markobj) (db->fname));
156 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
159 struct Lisp_Database *db = XDATABASE (obj);
162 error ("printing unreadable object #<database 0x%x>", db->header.uid);
164 write_c_string ("#<database \"", printcharfun);
165 print_internal (db->fname, printcharfun, 0);
166 sprintf (buf, "\" (%s/%s/%s) 0x%x>",
167 (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
168 (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
169 (!DATABASE_LIVE_P (db) ? "closed" :
170 (db->access_ & O_WRONLY) ? "writeonly" :
171 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
173 write_c_string (buf, printcharfun);
177 finalize_database (void *header, int for_disksave)
179 struct Lisp_Database *db = (struct Lisp_Database *) header;
184 XSETOBJ (obj, Lisp_Type_Record, (void *) db);
187 ("Can't dump an emacs containing database objects", obj);
189 db->funcs->close (db);
192 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
193 mark_database, print_database,
194 finalize_database, 0, 0,
195 struct Lisp_Database);
197 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
198 Close database DATABASE.
202 struct Lisp_Database *db;
203 CHECK_LIVE_DATABASE (database);
204 db = XDATABASE (database);
205 db->funcs->close (db);
210 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
211 Return the type of database DATABASE.
215 CHECK_DATABASE (database);
217 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
220 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
221 Return the subtype of database DATABASE, if any.
225 CHECK_DATABASE (database);
227 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
230 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
231 Return t if OBJ is an active database.
235 return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
238 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
239 Return the filename associated with the database DATABASE.
243 CHECK_DATABASE (database);
245 return XDATABASE (database)->fname;
248 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
249 Return t if OBJ is a database.
253 return DATABASEP (obj) ? Qt : Qnil;
258 dbm_map (struct Lisp_Database *db, Lisp_Object func)
260 datum keydatum, valdatum;
261 Lisp_Object key, val;
263 for (keydatum = dbm_firstkey (db->dbm_handle);
264 keydatum.dptr != NULL;
265 keydatum = dbm_nextkey (db->dbm_handle))
267 valdatum = dbm_fetch (db->dbm_handle, keydatum);
268 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
269 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
270 call2 (func, key, val);
275 dbm_get (struct Lisp_Database *db, Lisp_Object key)
277 datum keydatum, valdatum;
279 keydatum.dptr = (char *) XSTRING_DATA (key);
280 keydatum.dsize = XSTRING_LENGTH (key);
281 valdatum = dbm_fetch (db->dbm_handle, keydatum);
283 return (valdatum.dptr
284 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
289 dbm_put (struct Lisp_Database *db,
290 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
292 datum keydatum, valdatum;
294 valdatum.dptr = (char *) XSTRING_DATA (val);
295 valdatum.dsize = XSTRING_LENGTH (val);
296 keydatum.dptr = (char *) XSTRING_DATA (key);
297 keydatum.dsize = XSTRING_LENGTH (key);
299 return !dbm_store (db->dbm_handle, keydatum, valdatum,
300 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
304 dbm_remove (struct Lisp_Database *db, Lisp_Object key)
308 keydatum.dptr = (char *) XSTRING_DATA (key);
309 keydatum.dsize = XSTRING_LENGTH (key);
311 return dbm_delete (db->dbm_handle, keydatum);
315 dbm_type (struct Lisp_Database *db)
321 dbm_subtype (struct Lisp_Database *db)
327 dbm_lasterr (struct Lisp_Database *db)
329 return lisp_strerror (db->dberrno);
333 dbm_closeit (struct Lisp_Database *db)
337 dbm_close (db->dbm_handle);
338 db->dbm_handle = NULL;
342 static DB_FUNCS ndbm_func_block =
353 #endif /* HAVE_DBM */
355 #ifdef HAVE_BERKELEY_DB
357 berkdb_type (struct Lisp_Database *db)
363 berkdb_subtype (struct Lisp_Database *db)
368 switch (db->db_handle->type)
370 case DB_BTREE: return Qbtree;
371 case DB_HASH: return Qhash;
372 case DB_RECNO: return Qrecno;
373 default: return Qunknown;
378 berkdb_lasterr (struct Lisp_Database *db)
380 return lisp_strerror (db->dberrno);
384 berkdb_get (struct Lisp_Database *db, Lisp_Object key)
386 /* #### Needs mule-izing */
387 DBT keydatum, valdatum;
390 #if DB_VERSION_MAJOR == 2
391 /* Always initialize keydatum, valdatum. */
394 #endif /* DV_VERSION_MAJOR = 2 */
396 keydatum.data = XSTRING_DATA (key);
397 keydatum.size = XSTRING_LENGTH (key);
399 #if DB_VERSION_MAJOR == 1
400 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
402 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
403 #endif /* DB_VERSION_MAJOR */
406 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
408 #if DB_VERSION_MAJOR == 1
409 db->dberrno = (status == 1) ? -1 : errno;
411 db->dberrno = (status < 0) ? -1 : errno;
412 #endif /* DB_VERSION_MAJOR */
418 berkdb_put (struct Lisp_Database *db,
423 DBT keydatum, valdatum;
426 #if DB_VERSION_MAJOR == 2
427 /* Always initalize keydatum, valdatum. */
430 #endif /* DV_VERSION_MAJOR = 2 */
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;
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 */
450 berkdb_remove (struct Lisp_Database *db, Lisp_Object key)
455 #if DB_VERSION_MAJOR == 2
456 /* Always initialize keydatum. */
458 #endif /* DV_VERSION_MAJOR = 2 */
460 keydatum.data = XSTRING_DATA (key);
461 keydatum.size = XSTRING_LENGTH (key);
463 #if DB_VERSION_MAJOR == 1
464 status = db->db_handle->del (db->db_handle, &keydatum, 0);
466 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
467 #endif /* DB_VERSION_MAJOR */
472 #if DB_VERSION_MAJOR == 1
473 db->dberrno = (status == 1) ? -1 : errno;
475 db->dberrno = (status < 0) ? -1 : errno;
476 #endif /* DB_VERSION_MAJOR */
482 berkdb_map (struct Lisp_Database *db, Lisp_Object func)
484 DBT keydatum, valdatum;
485 Lisp_Object key, val;
486 DB *dbp = db->db_handle;
489 #if DB_VERSION_MAJOR == 1
490 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
492 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
494 /* ### Needs mule-izing */
495 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
496 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
497 call2 (func, key, val);
501 /* Initialize the key/data pair so the flags aren't set. */
505 status = dbp->cursor (dbp, NULL, &dbcp);
506 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
508 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
510 /* ### Needs mule-izing */
511 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
512 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
513 call2 (func, key, val);
515 dbcp->c_close (dbcp);
516 #endif /* DB_VERSION_MAJOR */
520 berkdb_close (struct Lisp_Database *db)
524 #if DB_VERSION_MAJOR == 1
525 db->db_handle->sync (db->db_handle, 0);
526 db->db_handle->close (db->db_handle);
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;
535 static DB_FUNCS berk_func_block =
546 #endif /* HAVE_BERKELEY_DB */
548 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
549 Return the last error associated with DATABASE.
554 return lisp_strerror (errno);
556 CHECK_DATABASE (database);
558 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
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.
569 (file, type, subtype, access_, mode))
571 /* This function can GC */
574 struct Lisp_Database *db = NULL;
576 struct gcpro gcpro1, gcpro2;
579 GCPRO2 (file, access_);
580 file = Fexpand_file_name (file, Qnil);
582 filename = (char *) XSTRING_DATA (file);
586 accessmask = O_RDWR | O_CREAT;
591 CHECK_STRING (access_);
592 acc = (char *) XSTRING_DATA (access_);
594 if (strchr (acc, '+'))
595 accessmask |= O_CREAT;
598 char *rp = strchr (acc, 'r');
599 char *wp = strchr (acc, 'w');
600 if (rp && wp) accessmask |= O_RDWR;
601 else if (wp) accessmask |= O_WRONLY;
602 else accessmask |= O_RDONLY;
608 modemask = 0755; /* rwxr-xr-x */
613 modemask = XINT (mode);
617 if (NILP (type) || EQ (type, Qdbm))
619 DBM *dbase = dbm_open (filename, accessmask, modemask);
623 db = allocate_database ();
624 db->dbm_handle = dbase;
626 db->funcs = &ndbm_func_block;
629 #endif /* HAVE_DBM */
631 #ifdef HAVE_BERKELEY_DB
632 if (NILP (type) || EQ (type, Qberkeley_db))
636 #if DB_VERSION_MAJOR != 1
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;
647 signal_simple_error ("Unsupported subtype", subtype);
649 #if DB_VERSION_MAJOR == 1
650 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
654 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
655 other flags shouldn't be set */
657 accessmask = DB_CREATE;
661 CHECK_STRING (access_);
662 acc = (char *) XSTRING_DATA (access_);
665 if (strchr (acc, '+'))
666 accessmask |= DB_CREATE;
668 if (strchr (acc, 'r') && !strchr (acc, 'w'))
669 accessmask |= DB_RDONLY;
671 status = db_open (filename, real_subtype, accessmask,
672 modemask, NULL , NULL, &dbase);
675 #endif /* DB_VERSION_MAJOR */
677 db = allocate_database ();
678 db->db_handle = dbase;
679 db->type = DB_BERKELEY;
680 db->funcs = &berk_func_block;
683 #endif /* HAVE_BERKELEY_DB */
685 signal_simple_error ("Unsupported database type", type);
692 db->access_ = accessmask;
696 XSETDATABASE (retval, db);
701 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
702 Store KEY and VALUE in DATABASE.
703 If optional fourth arg REPLACE is non-nil,
704 replace any existing entry in the database.
706 (key, value, database, replace))
708 CHECK_LIVE_DATABASE (database);
710 CHECK_STRING (value);
712 struct Lisp_Database *db = XDATABASE (database);
713 int status = db->funcs->put (db, key, value, replace);
714 return status ? Qt : Qnil;
718 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
719 Remove KEY from DATABASE.
723 CHECK_LIVE_DATABASE (database);
726 struct Lisp_Database *db = XDATABASE (database);
727 int status = db->funcs->rem (db, key);
728 return status ? Qt : Qnil;
732 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
733 Return value for KEY in DATABASE.
734 If there is no corresponding value, return DEFAULT (defaults to nil).
736 (key, database, default_))
738 CHECK_LIVE_DATABASE (database);
741 struct Lisp_Database *db = XDATABASE (database);
742 Lisp_Object retval = db->funcs->get (db, key);
743 return NILP (retval) ? default_ : retval;
747 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
748 Map FUNCTION over entries in DATABASE, calling it with two args,
749 each key and value in the database.
751 (function, database))
753 CHECK_LIVE_DATABASE (database);
755 XDATABASE (database)->funcs->map (XDATABASE (database), function);
761 syms_of_database (void)
763 defsymbol (&Qdatabasep, "databasep");
765 defsymbol (&Qdbm, "dbm");
767 #ifdef HAVE_BERKELEY_DB
768 defsymbol (&Qberkeley_db, "berkeley-db");
769 defsymbol (&Qhash, "hash");
770 defsymbol (&Qbtree, "btree");
771 defsymbol (&Qrecno, "recno");
772 defsymbol (&Qunknown, "unknown");
775 DEFSUBR (Fopen_database);
776 DEFSUBR (Fdatabasep);
777 DEFSUBR (Fmapdatabase);
778 DEFSUBR (Fput_database);
779 DEFSUBR (Fget_database);
780 DEFSUBR (Fremove_database);
781 DEFSUBR (Fdatabase_type);
782 DEFSUBR (Fdatabase_subtype);
783 DEFSUBR (Fdatabase_last_error);
784 DEFSUBR (Fdatabase_live_p);
785 DEFSUBR (Fdatabase_file_name);
786 DEFSUBR (Fclose_database);
790 vars_of_database (void)
795 #ifdef HAVE_BERKELEY_DB
796 Fprovide (Qberkeley_db);