1 /* Database access routines
2 Copyright (C) 1996, William M. Perry
4 This file is part of SXEmacs
6 SXEmacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 SXEmacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* Synched up with: Not in FSF. */
22 /* Written by Bill Perry */
23 /* Substantially rewritten by Martin Buchholz */
24 /* 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__
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;
54 #endif /* WE_DONT_NEED_QUADS */
55 #endif /* HAVE_INTTYPES_H */
56 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */
57 /* Berkeley DB wants __STDC__ to be defined; else if does `#define const' */
58 #if ! defined (__STDC__) && ! defined(__cplusplus)
61 #if defined(DB_H_FILE)
62 #include DB_H_FILE /* Berkeley db's header file */
64 #ifndef DB_VERSION_MAJOR
65 # define DB_VERSION_MAJOR 1
66 #endif /* DB_VERSION_MAJOR */
67 #ifndef DB_VERSION_MINOR
68 # define DB_VERSION_MINOR 0
69 #endif /* DB_VERSION_MINOR */
70 Lisp_Object Qberkeley_db;
71 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
72 #if DB_VERSION_MAJOR > 2
75 #endif /* HAVE_BERKELEY_DB */
83 /* #### The following should be settable on a per-database level.
84 But the whole coding-system infrastructure should be rewritten someday.
85 We really need coding-system aliases. -- martin */
86 Lisp_Object Vdatabase_coding_system;
89 Lisp_Object Qdatabasep;
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 *);
102 struct Lisp_Database {
103 struct lcrecord_header header;
112 #ifdef HAVE_BERKELEY_DB
117 Lisp_Object coding_system;
121 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
122 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
123 #define DATABASEP(x) RECORDP (x, database)
124 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
125 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
126 #define DATABASE_LIVE_P(x) (x->live_p)
128 #define CHECK_LIVE_DATABASE(db) do { \
129 CHECK_DATABASE (db); \
130 if (!DATABASE_LIVE_P (XDATABASE(db))) \
131 signal_simple_error ("Attempting to access closed database", db); \
134 static Lisp_Database *allocate_database(void)
137 alloc_lcrecord_type(Lisp_Database, &lrecord_database);
141 #ifdef HAVE_BERKELEY_DB
142 db->db_handle = NULL;
145 db->dbm_handle = NULL;
151 db->coding_system = Fget_coding_system(Qbinary);
156 static Lisp_Object mark_database(Lisp_Object object)
158 Lisp_Database *db = XDATABASE(object);
163 print_database(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
165 Lisp_Database *db = XDATABASE(obj);
166 Lisp_Object tmp1, tmp2;
168 if (print_readably) {
169 error("printing unreadable object #<database 0x%x>",
172 write_c_string("#<database \"", printcharfun);
173 print_internal(db->fname, printcharfun, 0);
175 tmp1 = db->funcs->get_type(db);
176 tmp2 = db->funcs->get_subtype(db);
177 write_fmt_string(printcharfun,
178 "\" (%s/%s/%s) 0x%x>",
179 (char *)string_data(XSYMBOL(tmp1)->name),
180 (char *)string_data(XSYMBOL(tmp2)->name),
181 (!DATABASE_LIVE_P(db) ? "closed" :
182 (db->access_ & O_WRONLY) ? "writeonly" :
183 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
187 static void finalize_database(void *header, int for_disksave)
189 Lisp_Database *db = (Lisp_Database *) header;
193 XSETDATABASE(object, db);
196 ("Can't dump an emacs containing database objects", object);
198 db->funcs->close(db);
201 DEFINE_LRECORD_IMPLEMENTATION("database", database,
202 mark_database, print_database,
203 finalize_database, 0, 0, 0, Lisp_Database);
205 DEFUN("close-database", Fclose_database, 1, 1, 0, /*
206 Close database DATABASE.
211 CHECK_LIVE_DATABASE(database);
212 db = XDATABASE(database);
213 db->funcs->close(db);
218 DEFUN("database-type", Fdatabase_type, 1, 1, 0, /*
219 Return the type of database DATABASE.
223 CHECK_DATABASE(database);
225 return XDATABASE(database)->funcs->get_type(XDATABASE(database));
228 DEFUN("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
229 Return the subtype of database DATABASE, if any.
233 CHECK_DATABASE(database);
235 return XDATABASE(database)->funcs->get_subtype(XDATABASE(database));
238 DEFUN("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
239 Return t if OBJECT is an active database.
243 return DATABASEP(object) && DATABASE_LIVE_P(XDATABASE(object)) ?
247 DEFUN("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
248 Return the filename associated with the database DATABASE.
252 CHECK_DATABASE(database);
254 return XDATABASE(database)->fname;
257 DEFUN("databasep", Fdatabasep, 1, 1, 0, /*
258 Return t if OBJECT is a database.
262 return DATABASEP(object) ? Qt : Qnil;
266 static void dbm_map(Lisp_Database * db, Lisp_Object func)
268 datum keydatum, valdatum;
269 Lisp_Object key, val;
271 for (keydatum = dbm_firstkey(db->dbm_handle);
272 keydatum.dptr != NULL; keydatum = dbm_nextkey(db->dbm_handle)) {
273 valdatum = dbm_fetch(db->dbm_handle, keydatum);
275 make_string((unsigned char *)keydatum.dptr, keydatum.dsize);
277 make_string((unsigned char *)valdatum.dptr, valdatum.dsize);
278 call2(func, key, val);
282 static Lisp_Object dbm_get(Lisp_Database * db, Lisp_Object key)
284 datum keydatum, valdatum;
286 keydatum.dptr = (char *)XSTRING_DATA(key);
287 keydatum.dsize = XSTRING_LENGTH(key);
288 valdatum = dbm_fetch(db->dbm_handle, keydatum);
290 return (valdatum.dptr
291 ? make_string((unsigned char *)valdatum.dptr, valdatum.dsize)
296 dbm_put(Lisp_Database * db,
297 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
299 datum keydatum, valdatum;
301 valdatum.dptr = (char *)XSTRING_DATA(val);
302 valdatum.dsize = XSTRING_LENGTH(val);
303 keydatum.dptr = (char *)XSTRING_DATA(key);
304 keydatum.dsize = XSTRING_LENGTH(key);
306 return !dbm_store(db->dbm_handle, keydatum, valdatum,
307 NILP(replace) ? DBM_INSERT : DBM_REPLACE);
310 static int dbm_remove(Lisp_Database * db, Lisp_Object key)
314 keydatum.dptr = (char *)XSTRING_DATA(key);
315 keydatum.dsize = XSTRING_LENGTH(key);
317 return dbm_delete(db->dbm_handle, keydatum);
320 static Lisp_Object dbm_type(Lisp_Database * db)
325 static Lisp_Object dbm_subtype(Lisp_Database * db)
330 static Lisp_Object dbm_lasterr(Lisp_Database * db)
332 return lisp_strerror(db->dberrno);
335 static void dbm_closeit(Lisp_Database * db)
337 if (db->dbm_handle) {
338 dbm_close(db->dbm_handle);
339 db->dbm_handle = NULL;
343 static DB_FUNCS ndbm_func_block = {
353 #endif /* HAVE_DBM */
355 #ifdef HAVE_BERKELEY_DB
356 static Lisp_Object berkdb_type(Lisp_Database * db)
361 static Lisp_Object berkdb_subtype(Lisp_Database * db)
366 switch (db->db_handle->type) {
373 #if DB_VERSION_MAJOR > 2
377 #ifdef HAVE_DB_UNKNOWN
385 static Lisp_Object berkdb_lasterr(Lisp_Database * db)
387 return lisp_strerror(db->dberrno);
390 static Lisp_Object berkdb_get(Lisp_Database * db, Lisp_Object key)
392 DBT keydatum, valdatum;
395 /* DB Version 2 requires DBT's to be zeroed before use. */
399 keydatum.data = XSTRING_DATA(key);
400 keydatum.size = XSTRING_LENGTH(key);
402 #if DB_VERSION_MAJOR == 1
403 status = db->db_handle->get(db->db_handle, &keydatum, &valdatum, 0);
406 db->db_handle->get(db->db_handle, NULL, &keydatum, &valdatum, 0);
407 #endif /* DB_VERSION_MAJOR */
410 /* #### Not mule-ized! will crash! */
411 return make_string((Bufbyte *) valdatum.data, valdatum.size);
413 #if DB_VERSION_MAJOR == 1
414 db->dberrno = (status == 1) ? -1 : errno;
416 db->dberrno = (status < 0) ? -1 : errno;
417 #endif /* DB_VERSION_MAJOR */
423 berkdb_put(Lisp_Database * db,
424 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
426 DBT keydatum, valdatum;
429 /* DB Version 2 requires DBT's to be zeroed before use. */
433 keydatum.data = XSTRING_DATA(key);
434 keydatum.size = XSTRING_LENGTH(key);
435 valdatum.data = XSTRING_DATA(val);
436 valdatum.size = XSTRING_LENGTH(val);
437 #if DB_VERSION_MAJOR == 1
438 status = db->db_handle->put(db->db_handle, &keydatum, &valdatum,
439 NILP(replace) ? R_NOOVERWRITE : 0);
440 db->dberrno = (status == 1) ? -1 : errno;
442 status = db->db_handle->put(db->db_handle, NULL, &keydatum, &valdatum,
443 NILP(replace) ? DB_NOOVERWRITE : 0);
444 db->dberrno = (status < 0) ? -1 : errno;
445 #endif /* DV_VERSION_MAJOR = 2 */
450 static int berkdb_remove(Lisp_Database * db, Lisp_Object key)
455 /* DB Version 2 requires DBT's to be zeroed before use. */
458 keydatum.data = XSTRING_DATA(key);
459 keydatum.size = XSTRING_LENGTH(key);
461 #if DB_VERSION_MAJOR == 1
462 status = db->db_handle->del(db->db_handle, &keydatum, 0);
464 status = db->db_handle->del(db->db_handle, NULL, &keydatum, 0);
465 #endif /* DB_VERSION_MAJOR */
470 #if DB_VERSION_MAJOR == 1
471 db->dberrno = (status == 1) ? -1 : errno;
473 db->dberrno = (status < 0) ? -1 : errno;
474 #endif /* DB_VERSION_MAJOR */
479 static void berkdb_map(Lisp_Database * db, Lisp_Object func)
481 DBT keydatum, valdatum;
482 Lisp_Object key, val;
483 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)) {
493 /* #### Needs mule-izing */
494 key = make_string((Bufbyte *) keydatum.data, keydatum.size);
495 val = make_string((Bufbyte *) valdatum.data, valdatum.size);
496 call2(func, key, val);
502 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
503 status = dbp->cursor(dbp, NULL, &dbcp, 0);
505 status = dbp->cursor(dbp, NULL, &dbcp);
507 for (status = dbcp->c_get(dbcp, &keydatum, &valdatum, DB_FIRST);
509 status = dbcp->c_get(dbcp, &keydatum, &valdatum, DB_NEXT))
511 /* #### Needs mule-izing */
513 make_string((Bufbyte *) keydatum.data,
516 make_string((Bufbyte *) valdatum.data,
518 call2(func, key, val);
522 #endif /* DB_VERSION_MAJOR */
525 static void berkdb_close(Lisp_Database * db)
528 #if DB_VERSION_MAJOR == 1
529 db->db_handle->sync(db->db_handle, 0);
530 db->db_handle->close(db->db_handle);
532 db->db_handle->sync(db->db_handle, 0);
533 db->db_handle->close(db->db_handle, 0);
534 #endif /* DB_VERSION_MAJOR */
535 db->db_handle = NULL;
539 static DB_FUNCS berk_func_block = {
549 #endif /* HAVE_BERKELEY_DB */
551 DEFUN("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
552 Return the last error associated with DATABASE.
557 return lisp_strerror(errno);
559 CHECK_DATABASE(database);
561 return XDATABASE(database)->funcs->last_error(XDATABASE(database));
564 DEFUN("open-database", Fopen_database, 1, 5, 0, /*
565 Return a new database object opened on FILE.
566 Optional arguments TYPE and SUBTYPE specify the database type.
567 Optional argument ACCESS specifies the access rights, which may be any
568 combination of 'r' 'w' and '+', for read, write, and creation flags.
569 Optional argument MODE gives the permissions to use when opening FILE,
570 and defaults to 0755.
572 (file, type, subtype, access_, mode))
574 /* This function can GC */
577 Lisp_Database *db = NULL;
579 struct gcpro gcpro1, gcpro2;
582 GCPRO2(file, access_);
583 file = Fexpand_file_name(file, Qnil);
586 TO_EXTERNAL_FORMAT(LISP_STRING, file,
587 C_STRING_ALLOCA, filename, Qfile_name);
590 accessmask = O_RDWR | O_CREAT;
593 CHECK_STRING(access_);
594 acc = (char *)XSTRING_DATA(access_);
596 if (strchr(acc, '+'))
597 accessmask |= O_CREAT;
600 char *rp = strchr(acc, 'r');
601 char *wp = strchr(acc, 'w');
603 accessmask |= O_RDWR;
605 accessmask |= O_WRONLY;
607 accessmask |= O_RDONLY;
612 modemask = 0755; /* rwxr-xr-x */
615 modemask = XINT(mode);
619 if (NILP(type) || EQ(type, Qdbm)) {
620 DBM *dbase = dbm_open(filename, accessmask, modemask);
624 db = allocate_database();
625 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)) {
635 #if DB_VERSION_MAJOR != 1
639 if (EQ(subtype, Qhash) || NILP(subtype))
640 real_subtype = DB_HASH;
641 else if (EQ(subtype, Qbtree))
642 real_subtype = DB_BTREE;
643 else if (EQ(subtype, Qrecno))
644 real_subtype = DB_RECNO;
645 #if DB_VERSION_MAJOR > 2
646 else if (EQ(subtype, Qqueue))
647 real_subtype = DB_QUEUE;
650 signal_simple_error("Unsupported subtype", subtype);
652 #if DB_VERSION_MAJOR == 1
654 dbopen(filename, accessmask, modemask, real_subtype, NULL);
658 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
659 other flags shouldn't be set */
661 accessmask = DB_CREATE;
664 CHECK_STRING(access_);
665 acc = (char *)XSTRING_DATA(access_);
668 if (strchr(acc, '+'))
669 accessmask |= DB_CREATE;
671 if (strchr(acc, 'r') && !strchr(acc, 'w'))
672 accessmask |= DB_RDONLY;
674 #if DB_VERSION_MAJOR == 2
675 status = db_open(filename, real_subtype, accessmask,
676 modemask, NULL, NULL, &dbase);
680 status = db_create(&dbase, NULL, 0);
683 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1)
684 status = dbase->open(dbase, filename, NULL,
685 real_subtype, accessmask, modemask);
686 #else /* DB_VERSION >= 4.1 */
687 /* DB_AUTO_COMMIT requires transaction support, don't try it */
688 status = dbase->open(dbase, NULL, filename, NULL, real_subtype,
689 accessmask, modemask);
690 #endif /* DB_VERSION < 4.1 */
692 dbase->close(dbase, 0);
695 #endif /* DB_VERSION_MAJOR > 2 */
696 /* Normalize into system specific file modes. Only for printing */
697 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
698 #endif /* DB_VERSION_MAJOR */
700 db = allocate_database();
701 db->db_handle = dbase;
702 db->funcs = &berk_func_block;
705 #endif /* HAVE_BERKELEY_DB */
707 signal_simple_error("Unsupported database type", type);
714 db->access_ = accessmask;
718 XSETDATABASE(retval, db);
723 DEFUN("put-database", Fput_database, 3, 4, 0, /*
724 Store KEY and VALUE in DATABASE.
725 If optional fourth arg REPLACE is non-nil,
726 replace any existing entry in the database.
728 (key, value, database, replace))
730 CHECK_LIVE_DATABASE(database);
734 Lisp_Database *db = XDATABASE(database);
735 int status = db->funcs->put(db, key, value, replace);
736 return status ? Qt : Qnil;
740 DEFUN("remove-database", Fremove_database, 2, 2, 0, /*
741 Remove KEY from DATABASE.
745 CHECK_LIVE_DATABASE(database);
748 Lisp_Database *db = XDATABASE(database);
749 int status = db->funcs->rem(db, key);
750 return status ? Qt : Qnil;
754 DEFUN("get-database", Fget_database, 2, 3, 0, /*
755 Return value for KEY in DATABASE.
756 If there is no corresponding value, return DEFAULT (defaults to nil).
758 (key, database, default_))
760 CHECK_LIVE_DATABASE(database);
763 Lisp_Database *db = XDATABASE(database);
764 Lisp_Object retval = db->funcs->get(db, key);
765 return NILP(retval) ? default_ : retval;
769 DEFUN("map-database", Fmapdatabase, 2, 2, 0, /*
770 Map FUNCTION over entries in DATABASE, calling it with two args,
771 each key and value in the database.
773 (function, database))
775 CHECK_LIVE_DATABASE(database);
777 XDATABASE(database)->funcs->map(XDATABASE(database), function);
782 void syms_of_database(void)
784 INIT_LRECORD_IMPLEMENTATION(database);
786 defsymbol(&Qdatabasep, "databasep");
788 defsymbol(&Qdbm, "dbm");
790 #ifdef HAVE_BERKELEY_DB
791 defsymbol(&Qberkeley_db, "berkeley-db");
792 defsymbol(&Qhash, "hash");
793 defsymbol(&Qbtree, "btree");
794 defsymbol(&Qrecno, "recno");
795 #if DB_VERSION_MAJOR > 2
796 defsymbol(&Qqueue, "queue");
798 defsymbol(&Qunknown, "unknown");
801 DEFSUBR(Fopen_database);
803 DEFSUBR(Fmapdatabase);
804 DEFSUBR(Fput_database);
805 DEFSUBR(Fget_database);
806 DEFSUBR(Fremove_database);
807 DEFSUBR(Fdatabase_type);
808 DEFSUBR(Fdatabase_subtype);
809 DEFSUBR(Fdatabase_last_error);
810 DEFSUBR(Fdatabase_live_p);
811 DEFSUBR(Fdatabase_file_name);
812 DEFSUBR(Fclose_database);
815 void vars_of_database(void)
820 #ifdef HAVE_BERKELEY_DB
821 Fprovide(Qberkeley_db);
824 #if 0 /* #### implement me! */
826 DEFVAR_LISP("database-coding-system", &Vdatabase_coding_system /*
827 Coding system used to convert data in database files.
829 Vdatabase_coding_system = Qnil;