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 GC_DATABASEP(x) GC_RECORDP (x, database)
117 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
118 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
119 #define DATABASE_LIVE_P(x) (x->live_p)
121 #define CHECK_LIVE_DATABASE(db) do { \
122 CHECK_DATABASE (db); \
123 if (!DATABASE_LIVE_P (XDATABASE(db))) \
124 signal_simple_error ("Attempting to access closed database", db); \
128 static Lisp_Database *
129 allocate_database (void)
131 Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, lrecord_database);
135 #ifdef HAVE_BERKELEY_DB
136 db->db_handle = NULL;
139 db->dbm_handle = NULL;
145 db->coding_system = Fget_coding_system (Qbinary);
151 mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object))
153 Lisp_Database *db = XDATABASE (obj);
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 (obj, db);
191 ("Can't dump an emacs containing database objects", obj);
193 db->funcs->close (db);
196 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
197 mark_database, print_database,
198 finalize_database, 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 OBJ is an active database.
239 return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
242 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
243 Return the filename associated with the database DATABASE.
247 CHECK_DATABASE (database);
249 return XDATABASE (database)->fname;
252 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
253 Return t if OBJ is a database.
257 return DATABASEP (obj) ? Qt : Qnil;
262 dbm_map (Lisp_Database *db, Lisp_Object func)
264 datum keydatum, valdatum;
265 Lisp_Object key, val;
267 for (keydatum = dbm_firstkey (db->dbm_handle);
268 keydatum.dptr != NULL;
269 keydatum = dbm_nextkey (db->dbm_handle))
271 valdatum = dbm_fetch (db->dbm_handle, keydatum);
272 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
273 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
274 call2 (func, key, val);
279 dbm_get (Lisp_Database *db, Lisp_Object key)
281 datum keydatum, valdatum;
283 keydatum.dptr = (char *) XSTRING_DATA (key);
284 keydatum.dsize = XSTRING_LENGTH (key);
285 valdatum = dbm_fetch (db->dbm_handle, keydatum);
287 return (valdatum.dptr
288 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
293 dbm_put (Lisp_Database *db,
294 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
296 datum keydatum, valdatum;
298 valdatum.dptr = (char *) XSTRING_DATA (val);
299 valdatum.dsize = XSTRING_LENGTH (val);
300 keydatum.dptr = (char *) XSTRING_DATA (key);
301 keydatum.dsize = XSTRING_LENGTH (key);
303 return !dbm_store (db->dbm_handle, keydatum, valdatum,
304 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
308 dbm_remove (Lisp_Database *db, Lisp_Object key)
312 keydatum.dptr = (char *) XSTRING_DATA (key);
313 keydatum.dsize = XSTRING_LENGTH (key);
315 return dbm_delete (db->dbm_handle, keydatum);
319 dbm_type (Lisp_Database *db)
325 dbm_subtype (Lisp_Database *db)
331 dbm_lasterr (Lisp_Database *db)
333 return lisp_strerror (db->dberrno);
337 dbm_closeit (Lisp_Database *db)
341 dbm_close (db->dbm_handle);
342 db->dbm_handle = NULL;
346 static DB_FUNCS ndbm_func_block =
357 #endif /* HAVE_DBM */
359 #ifdef HAVE_BERKELEY_DB
361 berkdb_type (Lisp_Database *db)
367 berkdb_subtype (Lisp_Database *db)
372 switch (db->db_handle->type)
374 case DB_BTREE: return Qbtree;
375 case DB_HASH: return Qhash;
376 case DB_RECNO: return Qrecno;
377 default: return Qunknown;
382 berkdb_lasterr (Lisp_Database *db)
384 return lisp_strerror (db->dberrno);
388 berkdb_get (Lisp_Database *db, Lisp_Object key)
390 DBT keydatum, valdatum;
393 /* DB Version 2 requires DBT's to be zeroed before use. */
397 keydatum.data = XSTRING_DATA (key);
398 keydatum.size = XSTRING_LENGTH (key);
400 #if DB_VERSION_MAJOR == 1
401 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
403 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
404 #endif /* DB_VERSION_MAJOR */
407 /* #### Not mule-ized! will crash! */
408 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
410 #if DB_VERSION_MAJOR == 1
411 db->dberrno = (status == 1) ? -1 : errno;
413 db->dberrno = (status < 0) ? -1 : errno;
414 #endif /* DB_VERSION_MAJOR */
420 berkdb_put (Lisp_Database *db,
425 DBT keydatum, valdatum;
428 /* DB Version 2 requires DBT's to be zeroed before use. */
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 (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 */
480 berkdb_map (Lisp_Database *db, Lisp_Object func)
482 DBT keydatum, valdatum;
483 Lisp_Object key, val;
484 DB *dbp = db->db_handle;
490 #if DB_VERSION_MAJOR == 1
491 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
493 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
495 /* ### Needs mule-izing */
496 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
497 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
498 call2 (func, key, val);
504 status = dbp->cursor (dbp, NULL, &dbcp);
505 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
507 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
509 /* ### Needs mule-izing */
510 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
511 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
512 call2 (func, key, val);
514 dbcp->c_close (dbcp);
516 #endif /* DB_VERSION_MAJOR */
520 berkdb_close (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 Lisp_Database *db = NULL;
576 struct gcpro gcpro1, gcpro2;
579 GCPRO2 (file, access_);
580 file = Fexpand_file_name (file, Qnil);
583 GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
587 accessmask = O_RDWR | O_CREAT;
592 CHECK_STRING (access_);
593 acc = (char *) XSTRING_DATA (access_);
595 if (strchr (acc, '+'))
596 accessmask |= O_CREAT;
599 char *rp = strchr (acc, 'r');
600 char *wp = strchr (acc, 'w');
601 if (rp && wp) accessmask |= O_RDWR;
602 else if (wp) accessmask |= O_WRONLY;
603 else accessmask |= O_RDONLY;
609 modemask = 0755; /* rwxr-xr-x */
614 modemask = XINT (mode);
618 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))
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->funcs = &berk_func_block;
682 #endif /* HAVE_BERKELEY_DB */
684 signal_simple_error ("Unsupported database type", type);
691 db->access_ = accessmask;
695 XSETDATABASE (retval, db);
700 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
701 Store KEY and VALUE in DATABASE.
702 If optional fourth arg REPLACE is non-nil,
703 replace any existing entry in the database.
705 (key, value, database, replace))
707 CHECK_LIVE_DATABASE (database);
709 CHECK_STRING (value);
711 Lisp_Database *db = XDATABASE (database);
712 int status = db->funcs->put (db, key, value, replace);
713 return status ? Qt : Qnil;
717 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
718 Remove KEY from DATABASE.
722 CHECK_LIVE_DATABASE (database);
725 Lisp_Database *db = XDATABASE (database);
726 int status = db->funcs->rem (db, key);
727 return status ? Qt : Qnil;
731 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
732 Return value for KEY in DATABASE.
733 If there is no corresponding value, return DEFAULT (defaults to nil).
735 (key, database, default_))
737 CHECK_LIVE_DATABASE (database);
740 Lisp_Database *db = XDATABASE (database);
741 Lisp_Object retval = db->funcs->get (db, key);
742 return NILP (retval) ? default_ : retval;
746 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
747 Map FUNCTION over entries in DATABASE, calling it with two args,
748 each key and value in the database.
750 (function, database))
752 CHECK_LIVE_DATABASE (database);
754 XDATABASE (database)->funcs->map (XDATABASE (database), function);
760 syms_of_database (void)
762 defsymbol (&Qdatabasep, "databasep");
764 defsymbol (&Qdbm, "dbm");
766 #ifdef HAVE_BERKELEY_DB
767 defsymbol (&Qberkeley_db, "berkeley-db");
768 defsymbol (&Qhash, "hash");
769 defsymbol (&Qbtree, "btree");
770 defsymbol (&Qrecno, "recno");
771 defsymbol (&Qunknown, "unknown");
774 DEFSUBR (Fopen_database);
775 DEFSUBR (Fdatabasep);
776 DEFSUBR (Fmapdatabase);
777 DEFSUBR (Fput_database);
778 DEFSUBR (Fget_database);
779 DEFSUBR (Fremove_database);
780 DEFSUBR (Fdatabase_type);
781 DEFSUBR (Fdatabase_subtype);
782 DEFSUBR (Fdatabase_last_error);
783 DEFSUBR (Fdatabase_live_p);
784 DEFSUBR (Fdatabase_file_name);
785 DEFSUBR (Fclose_database);
789 vars_of_database (void)
794 #ifdef HAVE_BERKELEY_DB
795 Fprovide (Qberkeley_db);
798 #if 0 /* #### implement me! */
800 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
801 Coding system used to convert data in database files.
803 Vdatabase_coding_system = Qnil;