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_PATH /* Berkeley db's header file */
57 #ifndef DB_VERSION_MAJOR
58 # define DB_VERSION_MAJOR 1
59 #endif /* DB_VERSION_MAJOR */
60 Lisp_Object Qberkeley_db;
61 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
62 #endif /* HAVE_BERKELEY_DB */
70 /* #### The following should be settable on a per-database level.
71 But the whole coding-system infrastructure should be rewritten someday.
72 We really need coding-system aliases. -- martin */
73 Lisp_Object Vdatabase_coding_system;
76 Lisp_Object Qdatabasep;
79 typedef struct Lisp_Database Lisp_Database;
83 Lisp_Object (*get_subtype) (Lisp_Database *);
84 Lisp_Object (*get_type) (Lisp_Database *);
85 Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
86 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
87 int (*rem) (Lisp_Database *, Lisp_Object);
88 void (*map) (Lisp_Database *, Lisp_Object);
89 void (*close) (Lisp_Database *);
90 Lisp_Object (*last_error) (Lisp_Database *);
95 struct lcrecord_header header;
104 #ifdef HAVE_BERKELEY_DB
109 Lisp_Object coding_system;
113 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
114 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
115 #define DATABASEP(x) RECORDP (x, database)
116 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
117 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
118 #define DATABASE_LIVE_P(x) (x->live_p)
120 #define CHECK_LIVE_DATABASE(db) do { \
121 CHECK_DATABASE (db); \
122 if (!DATABASE_LIVE_P (XDATABASE(db))) \
123 signal_simple_error ("Attempting to access closed database", db); \
127 static Lisp_Database *
128 allocate_database (void)
130 Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
134 #ifdef HAVE_BERKELEY_DB
135 db->db_handle = NULL;
138 db->dbm_handle = NULL;
144 db->coding_system = Fget_coding_system (Qbinary);
150 mark_database (Lisp_Object obj)
152 Lisp_Database *db = XDATABASE (obj);
157 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
160 Lisp_Database *db = XDATABASE (obj);
163 error ("printing unreadable object #<database 0x%x>", db->header.uid);
165 write_c_string ("#<database \"", printcharfun);
166 print_internal (db->fname, printcharfun, 0);
167 sprintf (buf, "\" (%s/%s/%s) 0x%x>",
168 (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
169 (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
170 (!DATABASE_LIVE_P (db) ? "closed" :
171 (db->access_ & O_WRONLY) ? "writeonly" :
172 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
174 write_c_string (buf, printcharfun);
178 finalize_database (void *header, int for_disksave)
180 Lisp_Database *db = (Lisp_Database *) header;
185 XSETDATABASE (obj, db);
188 ("Can't dump an emacs containing database objects", obj);
190 db->funcs->close (db);
193 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
194 mark_database, print_database,
195 finalize_database, 0, 0, 0,
198 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
199 Close database DATABASE.
204 CHECK_LIVE_DATABASE (database);
205 db = XDATABASE (database);
206 db->funcs->close (db);
211 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
212 Return the type of database DATABASE.
216 CHECK_DATABASE (database);
218 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
221 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
222 Return the subtype of database DATABASE, if any.
226 CHECK_DATABASE (database);
228 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
231 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
232 Return t if OBJ is an active database.
236 return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
239 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
240 Return the filename associated with the database DATABASE.
244 CHECK_DATABASE (database);
246 return XDATABASE (database)->fname;
249 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
250 Return t if OBJ is a database.
254 return DATABASEP (obj) ? Qt : Qnil;
259 dbm_map (Lisp_Database *db, Lisp_Object func)
261 datum keydatum, valdatum;
262 Lisp_Object key, val;
264 for (keydatum = dbm_firstkey (db->dbm_handle);
265 keydatum.dptr != NULL;
266 keydatum = dbm_nextkey (db->dbm_handle))
268 valdatum = dbm_fetch (db->dbm_handle, keydatum);
269 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
270 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
271 call2 (func, key, val);
276 dbm_get (Lisp_Database *db, Lisp_Object key)
278 datum keydatum, valdatum;
280 keydatum.dptr = (char *) XSTRING_DATA (key);
281 keydatum.dsize = XSTRING_LENGTH (key);
282 valdatum = dbm_fetch (db->dbm_handle, keydatum);
284 return (valdatum.dptr
285 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
290 dbm_put (Lisp_Database *db,
291 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
293 datum keydatum, valdatum;
295 valdatum.dptr = (char *) XSTRING_DATA (val);
296 valdatum.dsize = XSTRING_LENGTH (val);
297 keydatum.dptr = (char *) XSTRING_DATA (key);
298 keydatum.dsize = XSTRING_LENGTH (key);
300 return !dbm_store (db->dbm_handle, keydatum, valdatum,
301 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
305 dbm_remove (Lisp_Database *db, Lisp_Object key)
309 keydatum.dptr = (char *) XSTRING_DATA (key);
310 keydatum.dsize = XSTRING_LENGTH (key);
312 return dbm_delete (db->dbm_handle, keydatum);
316 dbm_type (Lisp_Database *db)
322 dbm_subtype (Lisp_Database *db)
328 dbm_lasterr (Lisp_Database *db)
330 return lisp_strerror (db->dberrno);
334 dbm_closeit (Lisp_Database *db)
338 dbm_close (db->dbm_handle);
339 db->dbm_handle = NULL;
343 static DB_FUNCS ndbm_func_block =
354 #endif /* HAVE_DBM */
356 #ifdef HAVE_BERKELEY_DB
358 berkdb_type (Lisp_Database *db)
364 berkdb_subtype (Lisp_Database *db)
369 switch (db->db_handle->type)
371 case DB_BTREE: return Qbtree;
372 case DB_HASH: return Qhash;
373 case DB_RECNO: return Qrecno;
374 default: return Qunknown;
379 berkdb_lasterr (Lisp_Database *db)
381 return lisp_strerror (db->dberrno);
385 berkdb_get (Lisp_Database *db, Lisp_Object key)
387 DBT keydatum, valdatum;
390 /* DB Version 2 requires DBT's to be zeroed before use. */
394 keydatum.data = XSTRING_DATA (key);
395 keydatum.size = XSTRING_LENGTH (key);
397 #if DB_VERSION_MAJOR == 1
398 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
400 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
401 #endif /* DB_VERSION_MAJOR */
404 /* #### Not mule-ized! will crash! */
405 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
407 #if DB_VERSION_MAJOR == 1
408 db->dberrno = (status == 1) ? -1 : errno;
410 db->dberrno = (status < 0) ? -1 : errno;
411 #endif /* DB_VERSION_MAJOR */
417 berkdb_put (Lisp_Database *db,
422 DBT keydatum, valdatum;
425 /* DB Version 2 requires DBT's to be zeroed before use. */
429 keydatum.data = XSTRING_DATA (key);
430 keydatum.size = XSTRING_LENGTH (key);
431 valdatum.data = XSTRING_DATA (val);
432 valdatum.size = XSTRING_LENGTH (val);
433 #if DB_VERSION_MAJOR == 1
434 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
435 NILP (replace) ? R_NOOVERWRITE : 0);
436 db->dberrno = (status == 1) ? -1 : errno;
438 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
439 NILP (replace) ? DB_NOOVERWRITE : 0);
440 db->dberrno = (status < 0) ? -1 : errno;
441 #endif/* DV_VERSION_MAJOR = 2 */
447 berkdb_remove (Lisp_Database *db, Lisp_Object key)
452 /* DB Version 2 requires DBT's to be zeroed before use. */
455 keydatum.data = XSTRING_DATA (key);
456 keydatum.size = XSTRING_LENGTH (key);
458 #if DB_VERSION_MAJOR == 1
459 status = db->db_handle->del (db->db_handle, &keydatum, 0);
461 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
462 #endif /* DB_VERSION_MAJOR */
467 #if DB_VERSION_MAJOR == 1
468 db->dberrno = (status == 1) ? -1 : errno;
470 db->dberrno = (status < 0) ? -1 : errno;
471 #endif /* DB_VERSION_MAJOR */
477 berkdb_map (Lisp_Database *db, Lisp_Object func)
479 DBT keydatum, valdatum;
480 Lisp_Object key, val;
481 DB *dbp = db->db_handle;
487 #if DB_VERSION_MAJOR == 1
488 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
490 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
492 /* ### Needs mule-izing */
493 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
494 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
495 call2 (func, key, val);
501 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
502 status = dbp->cursor (dbp, NULL, &dbcp, 0);
504 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);
517 #endif /* DB_VERSION_MAJOR */
521 berkdb_close (Lisp_Database *db)
525 #if DB_VERSION_MAJOR == 1
526 db->db_handle->sync (db->db_handle, 0);
527 db->db_handle->close (db->db_handle);
529 db->db_handle->sync (db->db_handle, 0);
530 db->db_handle->close (db->db_handle, 0);
531 #endif /* DB_VERSION_MAJOR */
532 db->db_handle = NULL;
536 static DB_FUNCS berk_func_block =
547 #endif /* HAVE_BERKELEY_DB */
549 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
550 Return the last error associated with DATABASE.
555 return lisp_strerror (errno);
557 CHECK_DATABASE (database);
559 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
562 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
563 Return a new database object opened on FILE.
564 Optional arguments TYPE and SUBTYPE specify the database type.
565 Optional argument ACCESS specifies the access rights, which may be any
566 combination of 'r' 'w' and '+', for read, write, and creation flags.
567 Optional argument MODE gives the permissions to use when opening FILE,
568 and defaults to 0755.
570 (file, type, subtype, access_, mode))
572 /* This function can GC */
575 Lisp_Database *db = NULL;
577 struct gcpro gcpro1, gcpro2;
580 GCPRO2 (file, access_);
581 file = Fexpand_file_name (file, Qnil);
584 GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
588 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');
602 if (rp && wp) accessmask |= O_RDWR;
603 else if (wp) accessmask |= O_WRONLY;
604 else accessmask |= O_RDONLY;
610 modemask = 0755; /* rwxr-xr-x */
615 modemask = XINT (mode);
619 if (NILP (type) || EQ (type, Qdbm))
621 DBM *dbase = dbm_open (filename, accessmask, modemask);
625 db = allocate_database ();
626 db->dbm_handle = dbase;
627 db->funcs = &ndbm_func_block;
630 #endif /* HAVE_DBM */
632 #ifdef HAVE_BERKELEY_DB
633 if (NILP (type) || EQ (type, Qberkeley_db))
637 #if DB_VERSION_MAJOR != 1
641 if (EQ (subtype, Qhash) || NILP (subtype))
642 real_subtype = DB_HASH;
643 else if (EQ (subtype, Qbtree))
644 real_subtype = DB_BTREE;
645 else if (EQ (subtype, Qrecno))
646 real_subtype = DB_RECNO;
648 signal_simple_error ("Unsupported subtype", subtype);
650 #if DB_VERSION_MAJOR == 1
651 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
655 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
656 other flags shouldn't be set */
658 accessmask = DB_CREATE;
662 CHECK_STRING (access_);
663 acc = (char *) XSTRING_DATA (access_);
666 if (strchr (acc, '+'))
667 accessmask |= DB_CREATE;
669 if (strchr (acc, 'r') && !strchr (acc, 'w'))
670 accessmask |= DB_RDONLY;
672 status = db_open (filename, real_subtype, accessmask,
673 modemask, NULL , NULL, &dbase);
676 #endif /* DB_VERSION_MAJOR */
678 db = allocate_database ();
679 db->db_handle = dbase;
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 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 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 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);
799 #if 0 /* #### implement me! */
801 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
802 Coding system used to convert data in database files.
804 Vdatabase_coding_system = Qnil;