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)
153 Lisp_Database *db = XDATABASE (obj);
158 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
161 Lisp_Database *db = XDATABASE (obj);
164 error ("printing unreadable object #<database 0x%x>", db->header.uid);
166 write_c_string ("#<database \"", printcharfun);
167 print_internal (db->fname, printcharfun, 0);
168 sprintf (buf, "\" (%s/%s/%s) 0x%x>",
169 (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
170 (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
171 (!DATABASE_LIVE_P (db) ? "closed" :
172 (db->access_ & O_WRONLY) ? "writeonly" :
173 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
175 write_c_string (buf, printcharfun);
179 finalize_database (void *header, int for_disksave)
181 Lisp_Database *db = (Lisp_Database *) header;
186 XSETDATABASE (obj, db);
189 ("Can't dump an emacs containing database objects", obj);
191 db->funcs->close (db);
194 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
195 mark_database, print_database,
196 finalize_database, 0, 0, 0,
199 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
200 Close database DATABASE.
205 CHECK_LIVE_DATABASE (database);
206 db = XDATABASE (database);
207 db->funcs->close (db);
212 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
213 Return the type of database DATABASE.
217 CHECK_DATABASE (database);
219 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
222 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
223 Return the subtype of database DATABASE, if any.
227 CHECK_DATABASE (database);
229 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
232 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
233 Return t if OBJ is an active database.
237 return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
240 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
241 Return the filename associated with the database DATABASE.
245 CHECK_DATABASE (database);
247 return XDATABASE (database)->fname;
250 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
251 Return t if OBJ is a database.
255 return DATABASEP (obj) ? Qt : Qnil;
260 dbm_map (Lisp_Database *db, Lisp_Object func)
262 datum keydatum, valdatum;
263 Lisp_Object key, val;
265 for (keydatum = dbm_firstkey (db->dbm_handle);
266 keydatum.dptr != NULL;
267 keydatum = dbm_nextkey (db->dbm_handle))
269 valdatum = dbm_fetch (db->dbm_handle, keydatum);
270 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
271 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
272 call2 (func, key, val);
277 dbm_get (Lisp_Database *db, Lisp_Object key)
279 datum keydatum, valdatum;
281 keydatum.dptr = (char *) XSTRING_DATA (key);
282 keydatum.dsize = XSTRING_LENGTH (key);
283 valdatum = dbm_fetch (db->dbm_handle, keydatum);
285 return (valdatum.dptr
286 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
291 dbm_put (Lisp_Database *db,
292 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
294 datum keydatum, valdatum;
296 valdatum.dptr = (char *) XSTRING_DATA (val);
297 valdatum.dsize = XSTRING_LENGTH (val);
298 keydatum.dptr = (char *) XSTRING_DATA (key);
299 keydatum.dsize = XSTRING_LENGTH (key);
301 return !dbm_store (db->dbm_handle, keydatum, valdatum,
302 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
306 dbm_remove (Lisp_Database *db, Lisp_Object key)
310 keydatum.dptr = (char *) XSTRING_DATA (key);
311 keydatum.dsize = XSTRING_LENGTH (key);
313 return dbm_delete (db->dbm_handle, keydatum);
317 dbm_type (Lisp_Database *db)
323 dbm_subtype (Lisp_Database *db)
329 dbm_lasterr (Lisp_Database *db)
331 return lisp_strerror (db->dberrno);
335 dbm_closeit (Lisp_Database *db)
339 dbm_close (db->dbm_handle);
340 db->dbm_handle = NULL;
344 static DB_FUNCS ndbm_func_block =
355 #endif /* HAVE_DBM */
357 #ifdef HAVE_BERKELEY_DB
359 berkdb_type (Lisp_Database *db)
365 berkdb_subtype (Lisp_Database *db)
370 switch (db->db_handle->type)
372 case DB_BTREE: return Qbtree;
373 case DB_HASH: return Qhash;
374 case DB_RECNO: return Qrecno;
375 default: return Qunknown;
380 berkdb_lasterr (Lisp_Database *db)
382 return lisp_strerror (db->dberrno);
386 berkdb_get (Lisp_Database *db, Lisp_Object key)
388 DBT keydatum, valdatum;
391 /* DB Version 2 requires DBT's to be zeroed before use. */
395 keydatum.data = XSTRING_DATA (key);
396 keydatum.size = XSTRING_LENGTH (key);
398 #if DB_VERSION_MAJOR == 1
399 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
401 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
402 #endif /* DB_VERSION_MAJOR */
405 /* #### Not mule-ized! will crash! */
406 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
408 #if DB_VERSION_MAJOR == 1
409 db->dberrno = (status == 1) ? -1 : errno;
411 db->dberrno = (status < 0) ? -1 : errno;
412 #endif /* DB_VERSION_MAJOR */
418 berkdb_put (Lisp_Database *db,
423 DBT keydatum, valdatum;
426 /* DB Version 2 requires DBT's to be zeroed before use. */
430 keydatum.data = XSTRING_DATA (key);
431 keydatum.size = XSTRING_LENGTH (key);
432 valdatum.data = XSTRING_DATA (val);
433 valdatum.size = XSTRING_LENGTH (val);
434 #if DB_VERSION_MAJOR == 1
435 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
436 NILP (replace) ? R_NOOVERWRITE : 0);
437 db->dberrno = (status == 1) ? -1 : errno;
439 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
440 NILP (replace) ? DB_NOOVERWRITE : 0);
441 db->dberrno = (status < 0) ? -1 : errno;
442 #endif/* DV_VERSION_MAJOR = 2 */
448 berkdb_remove (Lisp_Database *db, Lisp_Object key)
453 /* DB Version 2 requires DBT's to be zeroed before use. */
456 keydatum.data = XSTRING_DATA (key);
457 keydatum.size = XSTRING_LENGTH (key);
459 #if DB_VERSION_MAJOR == 1
460 status = db->db_handle->del (db->db_handle, &keydatum, 0);
462 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
463 #endif /* DB_VERSION_MAJOR */
468 #if DB_VERSION_MAJOR == 1
469 db->dberrno = (status == 1) ? -1 : errno;
471 db->dberrno = (status < 0) ? -1 : errno;
472 #endif /* DB_VERSION_MAJOR */
478 berkdb_map (Lisp_Database *db, Lisp_Object func)
480 DBT keydatum, valdatum;
481 Lisp_Object key, val;
482 DB *dbp = db->db_handle;
488 #if DB_VERSION_MAJOR == 1
489 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
491 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 */
512 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
513 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
514 call2 (func, key, val);
516 dbcp->c_close (dbcp);
518 #endif /* DB_VERSION_MAJOR */
522 berkdb_close (Lisp_Database *db)
526 #if DB_VERSION_MAJOR == 1
527 db->db_handle->sync (db->db_handle, 0);
528 db->db_handle->close (db->db_handle);
530 db->db_handle->sync (db->db_handle, 0);
531 db->db_handle->close (db->db_handle, 0);
532 #endif /* DB_VERSION_MAJOR */
533 db->db_handle = NULL;
537 static DB_FUNCS berk_func_block =
548 #endif /* HAVE_BERKELEY_DB */
550 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
551 Return the last error associated with DATABASE.
556 return lisp_strerror (errno);
558 CHECK_DATABASE (database);
560 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
563 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
564 Return a new database object opened on FILE.
565 Optional arguments TYPE and SUBTYPE specify the database type.
566 Optional argument ACCESS specifies the access rights, which may be any
567 combination of 'r' 'w' and '+', for read, write, and creation flags.
568 Optional argument MODE gives the permissions to use when opening FILE,
569 and defaults to 0755.
571 (file, type, subtype, access_, mode))
573 /* This function can GC */
576 Lisp_Database *db = NULL;
578 struct gcpro gcpro1, gcpro2;
581 GCPRO2 (file, access_);
582 file = Fexpand_file_name (file, Qnil);
585 GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
589 accessmask = O_RDWR | O_CREAT;
594 CHECK_STRING (access_);
595 acc = (char *) XSTRING_DATA (access_);
597 if (strchr (acc, '+'))
598 accessmask |= O_CREAT;
601 char *rp = strchr (acc, 'r');
602 char *wp = strchr (acc, 'w');
603 if (rp && wp) accessmask |= O_RDWR;
604 else if (wp) accessmask |= O_WRONLY;
605 else accessmask |= O_RDONLY;
611 modemask = 0755; /* rwxr-xr-x */
616 modemask = XINT (mode);
620 if (NILP (type) || EQ (type, Qdbm))
622 DBM *dbase = dbm_open (filename, accessmask, modemask);
626 db = allocate_database ();
627 db->dbm_handle = dbase;
628 db->funcs = &ndbm_func_block;
631 #endif /* HAVE_DBM */
633 #ifdef HAVE_BERKELEY_DB
634 if (NILP (type) || EQ (type, Qberkeley_db))
638 #if DB_VERSION_MAJOR != 1
642 if (EQ (subtype, Qhash) || NILP (subtype))
643 real_subtype = DB_HASH;
644 else if (EQ (subtype, Qbtree))
645 real_subtype = DB_BTREE;
646 else if (EQ (subtype, Qrecno))
647 real_subtype = DB_RECNO;
649 signal_simple_error ("Unsupported subtype", subtype);
651 #if DB_VERSION_MAJOR == 1
652 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
656 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
657 other flags shouldn't be set */
659 accessmask = DB_CREATE;
663 CHECK_STRING (access_);
664 acc = (char *) XSTRING_DATA (access_);
667 if (strchr (acc, '+'))
668 accessmask |= DB_CREATE;
670 if (strchr (acc, 'r') && !strchr (acc, 'w'))
671 accessmask |= DB_RDONLY;
673 status = db_open (filename, real_subtype, accessmask,
674 modemask, NULL , NULL, &dbase);
677 #endif /* DB_VERSION_MAJOR */
679 db = allocate_database ();
680 db->db_handle = dbase;
681 db->funcs = &berk_func_block;
684 #endif /* HAVE_BERKELEY_DB */
686 signal_simple_error ("Unsupported database type", type);
693 db->access_ = accessmask;
697 XSETDATABASE (retval, db);
702 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
703 Store KEY and VALUE in DATABASE.
704 If optional fourth arg REPLACE is non-nil,
705 replace any existing entry in the database.
707 (key, value, database, replace))
709 CHECK_LIVE_DATABASE (database);
711 CHECK_STRING (value);
713 Lisp_Database *db = XDATABASE (database);
714 int status = db->funcs->put (db, key, value, replace);
715 return status ? Qt : Qnil;
719 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
720 Remove KEY from DATABASE.
724 CHECK_LIVE_DATABASE (database);
727 Lisp_Database *db = XDATABASE (database);
728 int status = db->funcs->rem (db, key);
729 return status ? Qt : Qnil;
733 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
734 Return value for KEY in DATABASE.
735 If there is no corresponding value, return DEFAULT (defaults to nil).
737 (key, database, default_))
739 CHECK_LIVE_DATABASE (database);
742 Lisp_Database *db = XDATABASE (database);
743 Lisp_Object retval = db->funcs->get (db, key);
744 return NILP (retval) ? default_ : retval;
748 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
749 Map FUNCTION over entries in DATABASE, calling it with two args,
750 each key and value in the database.
752 (function, database))
754 CHECK_LIVE_DATABASE (database);
756 XDATABASE (database)->funcs->map (XDATABASE (database), function);
762 syms_of_database (void)
764 defsymbol (&Qdatabasep, "databasep");
766 defsymbol (&Qdbm, "dbm");
768 #ifdef HAVE_BERKELEY_DB
769 defsymbol (&Qberkeley_db, "berkeley-db");
770 defsymbol (&Qhash, "hash");
771 defsymbol (&Qbtree, "btree");
772 defsymbol (&Qrecno, "recno");
773 defsymbol (&Qunknown, "unknown");
776 DEFSUBR (Fopen_database);
777 DEFSUBR (Fdatabasep);
778 DEFSUBR (Fmapdatabase);
779 DEFSUBR (Fput_database);
780 DEFSUBR (Fget_database);
781 DEFSUBR (Fremove_database);
782 DEFSUBR (Fdatabase_type);
783 DEFSUBR (Fdatabase_subtype);
784 DEFSUBR (Fdatabase_last_error);
785 DEFSUBR (Fdatabase_live_p);
786 DEFSUBR (Fdatabase_file_name);
787 DEFSUBR (Fclose_database);
791 vars_of_database (void)
796 #ifdef HAVE_BERKELEY_DB
797 Fprovide (Qberkeley_db);
800 #if 0 /* #### implement me! */
802 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
803 Coding system used to convert data in database files.
805 Vdatabase_coding_system = Qnil;