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_FILE /* 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;
80 Lisp_Object (*get_subtype) (Lisp_Database *);
81 Lisp_Object (*get_type) (Lisp_Database *);
82 Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
83 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
84 int (*rem) (Lisp_Database *, Lisp_Object);
85 void (*map) (Lisp_Database *, Lisp_Object);
86 void (*close) (Lisp_Database *);
87 Lisp_Object (*last_error) (Lisp_Database *);
92 struct lcrecord_header header;
101 #ifdef HAVE_BERKELEY_DB
106 Lisp_Object coding_system;
110 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
111 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
112 #define DATABASEP(x) RECORDP (x, database)
113 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
114 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
115 #define DATABASE_LIVE_P(x) (x->live_p)
117 #define CHECK_LIVE_DATABASE(db) do { \
118 CHECK_DATABASE (db); \
119 if (!DATABASE_LIVE_P (XDATABASE(db))) \
120 signal_simple_error ("Attempting to access closed database", db); \
124 static Lisp_Database *
125 allocate_database (void)
127 Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
131 #ifdef HAVE_BERKELEY_DB
132 db->db_handle = NULL;
135 db->dbm_handle = NULL;
141 db->coding_system = Fget_coding_system (Qbinary);
147 mark_database (Lisp_Object object)
149 Lisp_Database *db = XDATABASE (object);
154 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
157 Lisp_Database *db = XDATABASE (obj);
160 error ("printing unreadable object #<database 0x%x>", db->header.uid);
162 write_c_string ("#<database \"", printcharfun);
163 print_internal (db->fname, printcharfun, 0);
164 sprintf (buf, "\" (%s/%s/%s) 0x%x>",
165 (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
166 (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
167 (!DATABASE_LIVE_P (db) ? "closed" :
168 (db->access_ & O_WRONLY) ? "writeonly" :
169 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
171 write_c_string (buf, printcharfun);
175 finalize_database (void *header, int for_disksave)
177 Lisp_Database *db = (Lisp_Database *) header;
182 XSETDATABASE (object, db);
185 ("Can't dump an emacs containing database objects", object);
187 db->funcs->close (db);
190 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
191 mark_database, print_database,
192 finalize_database, 0, 0, 0,
195 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
196 Close database DATABASE.
201 CHECK_LIVE_DATABASE (database);
202 db = XDATABASE (database);
203 db->funcs->close (db);
208 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
209 Return the type of database DATABASE.
213 CHECK_DATABASE (database);
215 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
218 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
219 Return the subtype of database DATABASE, if any.
223 CHECK_DATABASE (database);
225 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
228 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
229 Return t if OBJECT is an active database.
233 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
237 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
238 Return the filename associated with the database DATABASE.
242 CHECK_DATABASE (database);
244 return XDATABASE (database)->fname;
247 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
248 Return t if OBJECT is a database.
252 return DATABASEP (object) ? Qt : Qnil;
257 dbm_map (Lisp_Database *db, Lisp_Object func)
259 datum keydatum, valdatum;
260 Lisp_Object key, val;
262 for (keydatum = dbm_firstkey (db->dbm_handle);
263 keydatum.dptr != NULL;
264 keydatum = dbm_nextkey (db->dbm_handle))
266 valdatum = dbm_fetch (db->dbm_handle, keydatum);
267 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
268 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
269 call2 (func, key, val);
274 dbm_get (Lisp_Database *db, Lisp_Object key)
276 datum keydatum, valdatum;
278 keydatum.dptr = (char *) XSTRING_DATA (key);
279 keydatum.dsize = XSTRING_LENGTH (key);
280 valdatum = dbm_fetch (db->dbm_handle, keydatum);
282 return (valdatum.dptr
283 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
288 dbm_put (Lisp_Database *db,
289 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
291 datum keydatum, valdatum;
293 valdatum.dptr = (char *) XSTRING_DATA (val);
294 valdatum.dsize = XSTRING_LENGTH (val);
295 keydatum.dptr = (char *) XSTRING_DATA (key);
296 keydatum.dsize = XSTRING_LENGTH (key);
298 return !dbm_store (db->dbm_handle, keydatum, valdatum,
299 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
303 dbm_remove (Lisp_Database *db, Lisp_Object key)
307 keydatum.dptr = (char *) XSTRING_DATA (key);
308 keydatum.dsize = XSTRING_LENGTH (key);
310 return dbm_delete (db->dbm_handle, keydatum);
314 dbm_type (Lisp_Database *db)
320 dbm_subtype (Lisp_Database *db)
326 dbm_lasterr (Lisp_Database *db)
328 return lisp_strerror (db->dberrno);
332 dbm_closeit (Lisp_Database *db)
336 dbm_close (db->dbm_handle);
337 db->dbm_handle = NULL;
341 static DB_FUNCS ndbm_func_block =
352 #endif /* HAVE_DBM */
354 #ifdef HAVE_BERKELEY_DB
356 berkdb_type (Lisp_Database *db)
362 berkdb_subtype (Lisp_Database *db)
367 switch (db->db_handle->type)
369 case DB_BTREE: return Qbtree;
370 case DB_HASH: return Qhash;
371 case DB_RECNO: return Qrecno;
372 default: return Qunknown;
377 berkdb_lasterr (Lisp_Database *db)
379 return lisp_strerror (db->dberrno);
383 berkdb_get (Lisp_Database *db, Lisp_Object key)
385 DBT keydatum, valdatum;
388 /* DB Version 2 requires DBT's to be zeroed before use. */
392 keydatum.data = XSTRING_DATA (key);
393 keydatum.size = XSTRING_LENGTH (key);
395 #if DB_VERSION_MAJOR == 1
396 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
398 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
399 #endif /* DB_VERSION_MAJOR */
402 /* #### Not mule-ized! will crash! */
403 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
405 #if DB_VERSION_MAJOR == 1
406 db->dberrno = (status == 1) ? -1 : errno;
408 db->dberrno = (status < 0) ? -1 : errno;
409 #endif /* DB_VERSION_MAJOR */
415 berkdb_put (Lisp_Database *db,
420 DBT keydatum, valdatum;
423 /* DB Version 2 requires DBT's to be zeroed before use. */
427 keydatum.data = XSTRING_DATA (key);
428 keydatum.size = XSTRING_LENGTH (key);
429 valdatum.data = XSTRING_DATA (val);
430 valdatum.size = XSTRING_LENGTH (val);
431 #if DB_VERSION_MAJOR == 1
432 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
433 NILP (replace) ? R_NOOVERWRITE : 0);
434 db->dberrno = (status == 1) ? -1 : errno;
436 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
437 NILP (replace) ? DB_NOOVERWRITE : 0);
438 db->dberrno = (status < 0) ? -1 : errno;
439 #endif/* DV_VERSION_MAJOR = 2 */
445 berkdb_remove (Lisp_Database *db, Lisp_Object key)
450 /* DB Version 2 requires DBT's to be zeroed before use. */
453 keydatum.data = XSTRING_DATA (key);
454 keydatum.size = XSTRING_LENGTH (key);
456 #if DB_VERSION_MAJOR == 1
457 status = db->db_handle->del (db->db_handle, &keydatum, 0);
459 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
460 #endif /* DB_VERSION_MAJOR */
465 #if DB_VERSION_MAJOR == 1
466 db->dberrno = (status == 1) ? -1 : errno;
468 db->dberrno = (status < 0) ? -1 : errno;
469 #endif /* DB_VERSION_MAJOR */
475 berkdb_map (Lisp_Database *db, Lisp_Object func)
477 DBT keydatum, valdatum;
478 Lisp_Object key, val;
479 DB *dbp = db->db_handle;
485 #if DB_VERSION_MAJOR == 1
486 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
488 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
490 /* #### Needs mule-izing */
491 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
492 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
493 call2 (func, key, val);
499 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
500 status = dbp->cursor (dbp, NULL, &dbcp, 0);
502 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);
515 #endif /* DB_VERSION_MAJOR */
519 berkdb_close (Lisp_Database *db)
523 #if DB_VERSION_MAJOR == 1
524 db->db_handle->sync (db->db_handle, 0);
525 db->db_handle->close (db->db_handle);
527 db->db_handle->sync (db->db_handle, 0);
528 db->db_handle->close (db->db_handle, 0);
529 #endif /* DB_VERSION_MAJOR */
530 db->db_handle = NULL;
534 static DB_FUNCS berk_func_block =
545 #endif /* HAVE_BERKELEY_DB */
547 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
548 Return the last error associated with DATABASE.
553 return lisp_strerror (errno);
555 CHECK_DATABASE (database);
557 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
560 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
561 Return a new database object opened on FILE.
562 Optional arguments TYPE and SUBTYPE specify the database type.
563 Optional argument ACCESS specifies the access rights, which may be any
564 combination of 'r' 'w' and '+', for read, write, and creation flags.
565 Optional argument MODE gives the permissions to use when opening FILE,
566 and defaults to 0755.
568 (file, type, subtype, access_, mode))
570 /* This function can GC */
573 Lisp_Database *db = NULL;
575 struct gcpro gcpro1, gcpro2;
578 GCPRO2 (file, access_);
579 file = Fexpand_file_name (file, Qnil);
582 TO_EXTERNAL_FORMAT (LISP_STRING, file,
583 C_STRING_ALLOCA, 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 INIT_LRECORD_IMPLEMENTATION (database);
765 defsymbol (&Qdatabasep, "databasep");
767 defsymbol (&Qdbm, "dbm");
769 #ifdef HAVE_BERKELEY_DB
770 defsymbol (&Qberkeley_db, "berkeley-db");
771 defsymbol (&Qhash, "hash");
772 defsymbol (&Qbtree, "btree");
773 defsymbol (&Qrecno, "recno");
774 defsymbol (&Qunknown, "unknown");
777 DEFSUBR (Fopen_database);
778 DEFSUBR (Fdatabasep);
779 DEFSUBR (Fmapdatabase);
780 DEFSUBR (Fput_database);
781 DEFSUBR (Fget_database);
782 DEFSUBR (Fremove_database);
783 DEFSUBR (Fdatabase_type);
784 DEFSUBR (Fdatabase_subtype);
785 DEFSUBR (Fdatabase_last_error);
786 DEFSUBR (Fdatabase_live_p);
787 DEFSUBR (Fdatabase_file_name);
788 DEFSUBR (Fclose_database);
792 vars_of_database (void)
797 #ifdef HAVE_BERKELEY_DB
798 Fprovide (Qberkeley_db);
801 #if 0 /* #### implement me! */
803 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
804 Coding system used to convert data in database files.
806 Vdatabase_coding_system = Qnil;