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);
503 status = dbp->cursor (dbp, NULL, &dbcp);
504 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
506 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
508 /* ### Needs mule-izing */
509 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
510 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
511 call2 (func, key, val);
513 dbcp->c_close (dbcp);
514 #endif /* DB_VERSION_MAJOR */
518 berkdb_close (Lisp_Database *db)
522 #if DB_VERSION_MAJOR == 1
523 db->db_handle->sync (db->db_handle, 0);
524 db->db_handle->close (db->db_handle);
526 db->db_handle->sync (db->db_handle, 0);
527 db->db_handle->close (db->db_handle, 0);
528 #endif /* DB_VERSION_MAJOR */
529 db->db_handle = NULL;
533 static DB_FUNCS berk_func_block =
544 #endif /* HAVE_BERKELEY_DB */
546 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
547 Return the last error associated with DATABASE.
552 return lisp_strerror (errno);
554 CHECK_DATABASE (database);
556 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
559 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
560 Return a new database object opened on FILE.
561 Optional arguments TYPE and SUBTYPE specify the database type.
562 Optional argument ACCESS specifies the access rights, which may be any
563 combination of 'r' 'w' and '+', for read, write, and creation flags.
564 Optional argument MODE gives the permissions to use when opening FILE,
565 and defaults to 0755.
567 (file, type, subtype, access_, mode))
569 /* This function can GC */
572 Lisp_Database *db = NULL;
574 struct gcpro gcpro1, gcpro2;
577 GCPRO2 (file, access_);
578 file = Fexpand_file_name (file, Qnil);
581 GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
585 accessmask = O_RDWR | O_CREAT;
590 CHECK_STRING (access_);
591 acc = (char *) XSTRING_DATA (access_);
593 if (strchr (acc, '+'))
594 accessmask |= O_CREAT;
597 char *rp = strchr (acc, 'r');
598 char *wp = strchr (acc, 'w');
599 if (rp && wp) accessmask |= O_RDWR;
600 else if (wp) accessmask |= O_WRONLY;
601 else accessmask |= O_RDONLY;
607 modemask = 0755; /* rwxr-xr-x */
612 modemask = XINT (mode);
616 if (NILP (type) || EQ (type, Qdbm))
618 DBM *dbase = dbm_open (filename, accessmask, modemask);
622 db = allocate_database ();
623 db->dbm_handle = dbase;
624 db->funcs = &ndbm_func_block;
627 #endif /* HAVE_DBM */
629 #ifdef HAVE_BERKELEY_DB
630 if (NILP (type) || EQ (type, Qberkeley_db))
634 #if DB_VERSION_MAJOR != 1
638 if (EQ (subtype, Qhash) || NILP (subtype))
639 real_subtype = DB_HASH;
640 else if (EQ (subtype, Qbtree))
641 real_subtype = DB_BTREE;
642 else if (EQ (subtype, Qrecno))
643 real_subtype = DB_RECNO;
645 signal_simple_error ("Unsupported subtype", subtype);
647 #if DB_VERSION_MAJOR == 1
648 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
652 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
653 other flags shouldn't be set */
655 accessmask = DB_CREATE;
659 CHECK_STRING (access_);
660 acc = (char *) XSTRING_DATA (access_);
663 if (strchr (acc, '+'))
664 accessmask |= DB_CREATE;
666 if (strchr (acc, 'r') && !strchr (acc, 'w'))
667 accessmask |= DB_RDONLY;
669 status = db_open (filename, real_subtype, accessmask,
670 modemask, NULL , NULL, &dbase);
673 #endif /* DB_VERSION_MAJOR */
675 db = allocate_database ();
676 db->db_handle = dbase;
677 db->funcs = &berk_func_block;
680 #endif /* HAVE_BERKELEY_DB */
682 signal_simple_error ("Unsupported database type", type);
689 db->access_ = accessmask;
693 XSETDATABASE (retval, db);
698 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
699 Store KEY and VALUE in DATABASE.
700 If optional fourth arg REPLACE is non-nil,
701 replace any existing entry in the database.
703 (key, value, database, replace))
705 CHECK_LIVE_DATABASE (database);
707 CHECK_STRING (value);
709 Lisp_Database *db = XDATABASE (database);
710 int status = db->funcs->put (db, key, value, replace);
711 return status ? Qt : Qnil;
715 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
716 Remove KEY from DATABASE.
720 CHECK_LIVE_DATABASE (database);
723 Lisp_Database *db = XDATABASE (database);
724 int status = db->funcs->rem (db, key);
725 return status ? Qt : Qnil;
729 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
730 Return value for KEY in DATABASE.
731 If there is no corresponding value, return DEFAULT (defaults to nil).
733 (key, database, default_))
735 CHECK_LIVE_DATABASE (database);
738 Lisp_Database *db = XDATABASE (database);
739 Lisp_Object retval = db->funcs->get (db, key);
740 return NILP (retval) ? default_ : retval;
744 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
745 Map FUNCTION over entries in DATABASE, calling it with two args,
746 each key and value in the database.
748 (function, database))
750 CHECK_LIVE_DATABASE (database);
752 XDATABASE (database)->funcs->map (XDATABASE (database), function);
758 syms_of_database (void)
760 defsymbol (&Qdatabasep, "databasep");
762 defsymbol (&Qdbm, "dbm");
764 #ifdef HAVE_BERKELEY_DB
765 defsymbol (&Qberkeley_db, "berkeley-db");
766 defsymbol (&Qhash, "hash");
767 defsymbol (&Qbtree, "btree");
768 defsymbol (&Qrecno, "recno");
769 defsymbol (&Qunknown, "unknown");
772 DEFSUBR (Fopen_database);
773 DEFSUBR (Fdatabasep);
774 DEFSUBR (Fmapdatabase);
775 DEFSUBR (Fput_database);
776 DEFSUBR (Fget_database);
777 DEFSUBR (Fremove_database);
778 DEFSUBR (Fdatabase_type);
779 DEFSUBR (Fdatabase_subtype);
780 DEFSUBR (Fdatabase_last_error);
781 DEFSUBR (Fdatabase_live_p);
782 DEFSUBR (Fdatabase_file_name);
783 DEFSUBR (Fclose_database);
787 vars_of_database (void)
792 #ifdef HAVE_BERKELEY_DB
793 Fprovide (Qberkeley_db);
796 #if 0 /* #### implement me! */
798 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
799 Coding system used to convert data in database files.
801 Vdatabase_coding_system = Qnil;