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 */
34 #error HAVE_DATABASE not defined!!
37 #include "database.h" /* Our include file */
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__
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_FILE /* Berkeley db's header file */
57 #ifndef DB_VERSION_MAJOR
58 # define DB_VERSION_MAJOR 1
59 #endif /* DB_VERSION_MAJOR */
60 #ifndef DB_VERSION_MINOR
61 # define DB_VERSION_MINOR 0
62 #endif /* DB_VERSION_MINOR */
63 Lisp_Object Qberkeley_db;
64 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
65 #if DB_VERSION_MAJOR > 2
68 #endif /* HAVE_BERKELEY_DB */
76 /* #### The following should be settable on a per-database level.
77 But the whole coding-system infrastructure should be rewritten someday.
78 We really need coding-system aliases. -- martin */
79 Lisp_Object Vdatabase_coding_system;
82 Lisp_Object Qdatabasep;
86 Lisp_Object (*get_subtype) (Lisp_Database *);
87 Lisp_Object (*get_type) (Lisp_Database *);
88 Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
89 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
90 int (*rem) (Lisp_Database *, Lisp_Object);
91 void (*map) (Lisp_Database *, Lisp_Object);
92 void (*close) (Lisp_Database *);
93 Lisp_Object (*last_error) (Lisp_Database *);
98 struct lcrecord_header header;
107 #ifdef HAVE_BERKELEY_DB
112 Lisp_Object coding_system;
116 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
117 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
118 #define DATABASEP(x) RECORDP (x, database)
119 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
120 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
121 #define DATABASE_LIVE_P(x) (x->live_p)
123 #define CHECK_LIVE_DATABASE(db) do { \
124 CHECK_DATABASE (db); \
125 if (!DATABASE_LIVE_P (XDATABASE(db))) \
126 signal_simple_error ("Attempting to access closed database", db); \
130 static Lisp_Database *
131 allocate_database (void)
133 Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
137 #ifdef HAVE_BERKELEY_DB
138 db->db_handle = NULL;
141 db->dbm_handle = NULL;
147 db->coding_system = Fget_coding_system (Qbinary);
153 mark_database (Lisp_Object object)
155 Lisp_Database *db = XDATABASE (object);
160 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
163 Lisp_Database *db = XDATABASE (obj);
166 error ("printing unreadable object #<database 0x%x>", db->header.uid);
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"),
177 write_c_string (buf, printcharfun);
181 finalize_database (void *header, int for_disksave)
183 Lisp_Database *db = (Lisp_Database *) header;
188 XSETDATABASE (object, db);
191 ("Can't dump an emacs containing database objects", object);
193 db->funcs->close (db);
196 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
197 mark_database, print_database,
198 finalize_database, 0, 0, 0,
201 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
202 Close database DATABASE.
207 CHECK_LIVE_DATABASE (database);
208 db = XDATABASE (database);
209 db->funcs->close (db);
214 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
215 Return the type of database DATABASE.
219 CHECK_DATABASE (database);
221 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
224 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
225 Return the subtype of database DATABASE, if any.
229 CHECK_DATABASE (database);
231 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
234 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
235 Return t if OBJECT is an active database.
239 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
243 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
244 Return the filename associated with the database DATABASE.
248 CHECK_DATABASE (database);
250 return XDATABASE (database)->fname;
253 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
254 Return t if OBJECT is a database.
258 return DATABASEP (object) ? Qt : Qnil;
263 dbm_map (Lisp_Database *db, Lisp_Object func)
265 datum keydatum, valdatum;
266 Lisp_Object key, val;
268 for (keydatum = dbm_firstkey (db->dbm_handle);
269 keydatum.dptr != NULL;
270 keydatum = dbm_nextkey (db->dbm_handle))
272 valdatum = dbm_fetch (db->dbm_handle, keydatum);
273 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
274 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
275 call2 (func, key, val);
280 dbm_get (Lisp_Database *db, Lisp_Object key)
282 datum keydatum, valdatum;
284 keydatum.dptr = (char *) XSTRING_DATA (key);
285 keydatum.dsize = XSTRING_LENGTH (key);
286 valdatum = dbm_fetch (db->dbm_handle, keydatum);
288 return (valdatum.dptr
289 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
294 dbm_put (Lisp_Database *db,
295 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
297 datum keydatum, valdatum;
299 valdatum.dptr = (char *) XSTRING_DATA (val);
300 valdatum.dsize = XSTRING_LENGTH (val);
301 keydatum.dptr = (char *) XSTRING_DATA (key);
302 keydatum.dsize = XSTRING_LENGTH (key);
304 return !dbm_store (db->dbm_handle, keydatum, valdatum,
305 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
309 dbm_remove (Lisp_Database *db, Lisp_Object key)
313 keydatum.dptr = (char *) XSTRING_DATA (key);
314 keydatum.dsize = XSTRING_LENGTH (key);
316 return dbm_delete (db->dbm_handle, keydatum);
320 dbm_type (Lisp_Database *db)
326 dbm_subtype (Lisp_Database *db)
332 dbm_lasterr (Lisp_Database *db)
334 return lisp_strerror (db->dberrno);
338 dbm_closeit (Lisp_Database *db)
342 dbm_close (db->dbm_handle);
343 db->dbm_handle = NULL;
347 static DB_FUNCS ndbm_func_block =
358 #endif /* HAVE_DBM */
360 #ifdef HAVE_BERKELEY_DB
362 berkdb_type (Lisp_Database *db)
368 berkdb_subtype (Lisp_Database *db)
373 switch (db->db_handle->type)
375 case DB_BTREE: return Qbtree;
376 case DB_HASH: return Qhash;
377 case DB_RECNO: return Qrecno;
378 #if DB_VERSION_MAJOR > 2
379 case DB_QUEUE: return Qqueue;
381 default: return Qunknown;
386 berkdb_lasterr (Lisp_Database *db)
388 return lisp_strerror (db->dberrno);
392 berkdb_get (Lisp_Database *db, Lisp_Object key)
394 DBT keydatum, valdatum;
397 /* DB Version 2 requires DBT's to be zeroed before use. */
401 keydatum.data = XSTRING_DATA (key);
402 keydatum.size = XSTRING_LENGTH (key);
404 #if DB_VERSION_MAJOR == 1
405 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
407 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
408 #endif /* DB_VERSION_MAJOR */
411 /* #### Not mule-ized! will crash! */
412 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
414 #if DB_VERSION_MAJOR == 1
415 db->dberrno = (status == 1) ? -1 : errno;
417 db->dberrno = (status < 0) ? -1 : errno;
418 #endif /* DB_VERSION_MAJOR */
424 berkdb_put (Lisp_Database *db,
429 DBT keydatum, valdatum;
432 /* DB Version 2 requires DBT's to be zeroed before use. */
436 keydatum.data = XSTRING_DATA (key);
437 keydatum.size = XSTRING_LENGTH (key);
438 valdatum.data = XSTRING_DATA (val);
439 valdatum.size = XSTRING_LENGTH (val);
440 #if DB_VERSION_MAJOR == 1
441 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
442 NILP (replace) ? R_NOOVERWRITE : 0);
443 db->dberrno = (status == 1) ? -1 : errno;
445 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
446 NILP (replace) ? DB_NOOVERWRITE : 0);
447 db->dberrno = (status < 0) ? -1 : errno;
448 #endif/* DV_VERSION_MAJOR = 2 */
454 berkdb_remove (Lisp_Database *db, Lisp_Object key)
459 /* DB Version 2 requires DBT's to be zeroed before use. */
462 keydatum.data = XSTRING_DATA (key);
463 keydatum.size = XSTRING_LENGTH (key);
465 #if DB_VERSION_MAJOR == 1
466 status = db->db_handle->del (db->db_handle, &keydatum, 0);
468 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
469 #endif /* DB_VERSION_MAJOR */
474 #if DB_VERSION_MAJOR == 1
475 db->dberrno = (status == 1) ? -1 : errno;
477 db->dberrno = (status < 0) ? -1 : errno;
478 #endif /* DB_VERSION_MAJOR */
484 berkdb_map (Lisp_Database *db, Lisp_Object func)
486 DBT keydatum, valdatum;
487 Lisp_Object key, val;
488 DB *dbp = db->db_handle;
494 #if DB_VERSION_MAJOR == 1
495 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
497 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
499 /* #### Needs mule-izing */
500 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
501 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
502 call2 (func, key, val);
508 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
509 status = dbp->cursor (dbp, NULL, &dbcp, 0);
511 status = dbp->cursor (dbp, NULL, &dbcp);
513 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
515 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
517 /* #### Needs mule-izing */
518 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
519 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
520 call2 (func, key, val);
522 dbcp->c_close (dbcp);
524 #endif /* DB_VERSION_MAJOR */
528 berkdb_close (Lisp_Database *db)
532 #if DB_VERSION_MAJOR == 1
533 db->db_handle->sync (db->db_handle, 0);
534 db->db_handle->close (db->db_handle);
536 db->db_handle->sync (db->db_handle, 0);
537 db->db_handle->close (db->db_handle, 0);
538 #endif /* DB_VERSION_MAJOR */
539 db->db_handle = NULL;
543 static DB_FUNCS berk_func_block =
554 #endif /* HAVE_BERKELEY_DB */
556 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
557 Return the last error associated with DATABASE.
562 return lisp_strerror (errno);
564 CHECK_DATABASE (database);
566 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
569 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
570 Return a new database object opened on FILE.
571 Optional arguments TYPE and SUBTYPE specify the database type.
572 Optional argument ACCESS specifies the access rights, which may be any
573 combination of 'r' 'w' and '+', for read, write, and creation flags.
574 Optional argument MODE gives the permissions to use when opening FILE,
575 and defaults to 0755.
577 (file, type, subtype, access_, mode))
579 /* This function can GC */
582 Lisp_Database *db = NULL;
584 struct gcpro gcpro1, gcpro2;
587 GCPRO2 (file, access_);
588 file = Fexpand_file_name (file, Qnil);
591 TO_EXTERNAL_FORMAT (LISP_STRING, file,
592 C_STRING_ALLOCA, filename,
597 accessmask = O_RDWR | O_CREAT;
602 CHECK_STRING (access_);
603 acc = (char *) XSTRING_DATA (access_);
605 if (strchr (acc, '+'))
606 accessmask |= O_CREAT;
609 char *rp = strchr (acc, 'r');
610 char *wp = strchr (acc, 'w');
611 if (rp && wp) accessmask |= O_RDWR;
612 else if (wp) accessmask |= O_WRONLY;
613 else accessmask |= O_RDONLY;
619 modemask = 0755; /* rwxr-xr-x */
624 modemask = XINT (mode);
628 if (NILP (type) || EQ (type, Qdbm))
630 DBM *dbase = dbm_open (filename, accessmask, modemask);
634 db = allocate_database ();
635 db->dbm_handle = dbase;
636 db->funcs = &ndbm_func_block;
639 #endif /* HAVE_DBM */
641 #ifdef HAVE_BERKELEY_DB
642 if (NILP (type) || EQ (type, Qberkeley_db))
646 #if DB_VERSION_MAJOR != 1
650 if (EQ (subtype, Qhash) || NILP (subtype))
651 real_subtype = DB_HASH;
652 else if (EQ (subtype, Qbtree))
653 real_subtype = DB_BTREE;
654 else if (EQ (subtype, Qrecno))
655 real_subtype = DB_RECNO;
656 #if DB_VERSION_MAJOR > 2
657 else if (EQ (subtype, Qqueue))
658 real_subtype = DB_QUEUE;
661 signal_simple_error ("Unsupported subtype", subtype);
663 #if DB_VERSION_MAJOR == 1
664 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
668 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
669 other flags shouldn't be set */
671 accessmask = DB_CREATE;
675 CHECK_STRING (access_);
676 acc = (char *) XSTRING_DATA (access_);
679 if (strchr (acc, '+'))
680 accessmask |= DB_CREATE;
682 if (strchr (acc, 'r') && !strchr (acc, 'w'))
683 accessmask |= DB_RDONLY;
685 #if DB_VERSION_MAJOR == 2
686 status = db_open (filename, real_subtype, accessmask,
687 modemask, NULL , NULL, &dbase);
691 status = db_create (&dbase, NULL, 0);
694 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1)
695 status = dbase->open (dbase, filename, NULL,
696 real_subtype, accessmask, modemask);
697 #else /* DB_VERSION >= 4.1 */
698 status = dbase->open (dbase, NULL, filename, NULL, real_subtype,
699 accessmask | DB_AUTO_COMMIT, modemask);
700 #endif /* DB_VERSION < 4.1 */
703 dbase->close (dbase, 0);
706 #endif /* DB_VERSION_MAJOR > 2 */
707 /* Normalize into system specific file modes. Only for printing */
708 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
709 #endif /* DB_VERSION_MAJOR */
711 db = allocate_database ();
712 db->db_handle = dbase;
713 db->funcs = &berk_func_block;
716 #endif /* HAVE_BERKELEY_DB */
718 signal_simple_error ("Unsupported database type", type);
725 db->access_ = accessmask;
729 XSETDATABASE (retval, db);
734 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
735 Store KEY and VALUE in DATABASE.
736 If optional fourth arg REPLACE is non-nil,
737 replace any existing entry in the database.
739 (key, value, database, replace))
741 CHECK_LIVE_DATABASE (database);
743 CHECK_STRING (value);
745 Lisp_Database *db = XDATABASE (database);
746 int status = db->funcs->put (db, key, value, replace);
747 return status ? Qt : Qnil;
751 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
752 Remove KEY from DATABASE.
756 CHECK_LIVE_DATABASE (database);
759 Lisp_Database *db = XDATABASE (database);
760 int status = db->funcs->rem (db, key);
761 return status ? Qt : Qnil;
765 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
766 Return value for KEY in DATABASE.
767 If there is no corresponding value, return DEFAULT (defaults to nil).
769 (key, database, default_))
771 CHECK_LIVE_DATABASE (database);
774 Lisp_Database *db = XDATABASE (database);
775 Lisp_Object retval = db->funcs->get (db, key);
776 return NILP (retval) ? default_ : retval;
780 DEFUN ("map-database", Fmap_database, 2, 2, 0, /*
781 Map FUNCTION over entries in DATABASE, calling it with two args,
782 each key and value in the database.
784 (function, database))
786 CHECK_LIVE_DATABASE (database);
788 XDATABASE (database)->funcs->map (XDATABASE (database), function);
794 syms_of_database (void)
796 INIT_LRECORD_IMPLEMENTATION (database);
798 defsymbol (&Qdatabasep, "databasep");
800 defsymbol (&Qdbm, "dbm");
802 #ifdef HAVE_BERKELEY_DB
803 defsymbol (&Qberkeley_db, "berkeley-db");
804 defsymbol (&Qhash, "hash");
805 defsymbol (&Qbtree, "btree");
806 defsymbol (&Qrecno, "recno");
807 #if DB_VERSION_MAJOR > 2
808 defsymbol (&Qqueue, "queue");
810 defsymbol (&Qunknown, "unknown");
813 DEFSUBR (Fopen_database);
814 DEFSUBR (Fdatabasep);
815 DEFSUBR (Fmap_database);
816 DEFSUBR (Fput_database);
817 DEFSUBR (Fget_database);
818 DEFSUBR (Fremove_database);
819 DEFSUBR (Fdatabase_type);
820 DEFSUBR (Fdatabase_subtype);
821 DEFSUBR (Fdatabase_last_error);
822 DEFSUBR (Fdatabase_live_p);
823 DEFSUBR (Fdatabase_file_name);
824 DEFSUBR (Fclose_database);
828 vars_of_database (void)
833 #ifdef HAVE_BERKELEY_DB
834 Fprovide (Qberkeley_db);
837 #if 0 /* #### implement me! */
839 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
840 Coding system used to convert data in database files.
842 Vdatabase_coding_system = Qnil;