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 #if DB_VERSION_MAJOR > 2
65 #endif /* HAVE_BERKELEY_DB */
73 /* #### The following should be settable on a per-database level.
74 But the whole coding-system infrastructure should be rewritten someday.
75 We really need coding-system aliases. -- martin */
76 Lisp_Object Vdatabase_coding_system;
79 Lisp_Object Qdatabasep;
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 object)
152 Lisp_Database *db = XDATABASE (object);
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 (object, db);
188 ("Can't dump an emacs containing database objects", object);
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 OBJECT is an active database.
236 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
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 OBJECT is a database.
255 return DATABASEP (object) ? 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 #if DB_VERSION_MAJOR > 2
376 case DB_QUEUE: return Qqueue;
378 default: return Qunknown;
383 berkdb_lasterr (Lisp_Database *db)
385 return lisp_strerror (db->dberrno);
389 berkdb_get (Lisp_Database *db, Lisp_Object key)
391 DBT keydatum, valdatum;
394 /* DB Version 2 requires DBT's to be zeroed before use. */
398 keydatum.data = XSTRING_DATA (key);
399 keydatum.size = XSTRING_LENGTH (key);
401 #if DB_VERSION_MAJOR == 1
402 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
404 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
405 #endif /* DB_VERSION_MAJOR */
408 /* #### Not mule-ized! will crash! */
409 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
411 #if DB_VERSION_MAJOR == 1
412 db->dberrno = (status == 1) ? -1 : errno;
414 db->dberrno = (status < 0) ? -1 : errno;
415 #endif /* DB_VERSION_MAJOR */
421 berkdb_put (Lisp_Database *db,
426 DBT keydatum, valdatum;
429 /* DB Version 2 requires DBT's to be zeroed before use. */
433 keydatum.data = XSTRING_DATA (key);
434 keydatum.size = XSTRING_LENGTH (key);
435 valdatum.data = XSTRING_DATA (val);
436 valdatum.size = XSTRING_LENGTH (val);
437 #if DB_VERSION_MAJOR == 1
438 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
439 NILP (replace) ? R_NOOVERWRITE : 0);
440 db->dberrno = (status == 1) ? -1 : errno;
442 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
443 NILP (replace) ? DB_NOOVERWRITE : 0);
444 db->dberrno = (status < 0) ? -1 : errno;
445 #endif/* DV_VERSION_MAJOR = 2 */
451 berkdb_remove (Lisp_Database *db, Lisp_Object key)
456 /* DB Version 2 requires DBT's to be zeroed before use. */
459 keydatum.data = XSTRING_DATA (key);
460 keydatum.size = XSTRING_LENGTH (key);
462 #if DB_VERSION_MAJOR == 1
463 status = db->db_handle->del (db->db_handle, &keydatum, 0);
465 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
466 #endif /* DB_VERSION_MAJOR */
471 #if DB_VERSION_MAJOR == 1
472 db->dberrno = (status == 1) ? -1 : errno;
474 db->dberrno = (status < 0) ? -1 : errno;
475 #endif /* DB_VERSION_MAJOR */
481 berkdb_map (Lisp_Database *db, Lisp_Object func)
483 DBT keydatum, valdatum;
484 Lisp_Object key, val;
485 DB *dbp = db->db_handle;
491 #if DB_VERSION_MAJOR == 1
492 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
494 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
496 /* #### Needs mule-izing */
497 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
498 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
499 call2 (func, key, val);
505 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
506 status = dbp->cursor (dbp, NULL, &dbcp, 0);
508 status = dbp->cursor (dbp, NULL, &dbcp);
510 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
512 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
514 /* #### Needs mule-izing */
515 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
516 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
517 call2 (func, key, val);
519 dbcp->c_close (dbcp);
521 #endif /* DB_VERSION_MAJOR */
525 berkdb_close (Lisp_Database *db)
529 #if DB_VERSION_MAJOR == 1
530 db->db_handle->sync (db->db_handle, 0);
531 db->db_handle->close (db->db_handle);
533 db->db_handle->sync (db->db_handle, 0);
534 db->db_handle->close (db->db_handle, 0);
535 #endif /* DB_VERSION_MAJOR */
536 db->db_handle = NULL;
540 static DB_FUNCS berk_func_block =
551 #endif /* HAVE_BERKELEY_DB */
553 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
554 Return the last error associated with DATABASE.
559 return lisp_strerror (errno);
561 CHECK_DATABASE (database);
563 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
566 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
567 Return a new database object opened on FILE.
568 Optional arguments TYPE and SUBTYPE specify the database type.
569 Optional argument ACCESS specifies the access rights, which may be any
570 combination of 'r' 'w' and '+', for read, write, and creation flags.
571 Optional argument MODE gives the permissions to use when opening FILE,
572 and defaults to 0755.
574 (file, type, subtype, access_, mode))
576 /* This function can GC */
579 Lisp_Database *db = NULL;
581 struct gcpro gcpro1, gcpro2;
584 GCPRO2 (file, access_);
585 file = Fexpand_file_name (file, Qnil);
588 TO_EXTERNAL_FORMAT (LISP_STRING, file,
589 C_STRING_ALLOCA, filename,
594 accessmask = O_RDWR | O_CREAT;
599 CHECK_STRING (access_);
600 acc = (char *) XSTRING_DATA (access_);
602 if (strchr (acc, '+'))
603 accessmask |= O_CREAT;
606 char *rp = strchr (acc, 'r');
607 char *wp = strchr (acc, 'w');
608 if (rp && wp) accessmask |= O_RDWR;
609 else if (wp) accessmask |= O_WRONLY;
610 else accessmask |= O_RDONLY;
616 modemask = 0755; /* rwxr-xr-x */
621 modemask = XINT (mode);
625 if (NILP (type) || EQ (type, Qdbm))
627 DBM *dbase = dbm_open (filename, accessmask, modemask);
631 db = allocate_database ();
632 db->dbm_handle = dbase;
633 db->funcs = &ndbm_func_block;
636 #endif /* HAVE_DBM */
638 #ifdef HAVE_BERKELEY_DB
639 if (NILP (type) || EQ (type, Qberkeley_db))
643 #if DB_VERSION_MAJOR != 1
647 if (EQ (subtype, Qhash) || NILP (subtype))
648 real_subtype = DB_HASH;
649 else if (EQ (subtype, Qbtree))
650 real_subtype = DB_BTREE;
651 else if (EQ (subtype, Qrecno))
652 real_subtype = DB_RECNO;
653 #if DB_VERSION_MAJOR > 2
654 else if (EQ (subtype, Qqueue))
655 real_subtype = DB_QUEUE;
658 signal_simple_error ("Unsupported subtype", subtype);
660 #if DB_VERSION_MAJOR == 1
661 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
665 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
666 other flags shouldn't be set */
668 accessmask = DB_CREATE;
672 CHECK_STRING (access_);
673 acc = (char *) XSTRING_DATA (access_);
676 if (strchr (acc, '+'))
677 accessmask |= DB_CREATE;
679 if (strchr (acc, 'r') && !strchr (acc, 'w'))
680 accessmask |= DB_RDONLY;
682 #if DB_VERSION_MAJOR == 2
683 status = db_open (filename, real_subtype, accessmask,
684 modemask, NULL , NULL, &dbase);
688 status = db_create (&dbase, NULL, 0);
691 status = dbase->open (dbase, filename, NULL,
692 real_subtype, accessmask, modemask);
695 dbase->close (dbase, 0);
698 #endif /* DB_VERSION_MAJOR > 2 */
699 /* Normalize into system specific file modes. Only for printing */
700 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
701 #endif /* DB_VERSION_MAJOR */
703 db = allocate_database ();
704 db->db_handle = dbase;
705 db->funcs = &berk_func_block;
708 #endif /* HAVE_BERKELEY_DB */
710 signal_simple_error ("Unsupported database type", type);
717 db->access_ = accessmask;
721 XSETDATABASE (retval, db);
726 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
727 Store KEY and VALUE in DATABASE.
728 If optional fourth arg REPLACE is non-nil,
729 replace any existing entry in the database.
731 (key, value, database, replace))
733 CHECK_LIVE_DATABASE (database);
735 CHECK_STRING (value);
737 Lisp_Database *db = XDATABASE (database);
738 int status = db->funcs->put (db, key, value, replace);
739 return status ? Qt : Qnil;
743 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
744 Remove KEY from DATABASE.
748 CHECK_LIVE_DATABASE (database);
751 Lisp_Database *db = XDATABASE (database);
752 int status = db->funcs->rem (db, key);
753 return status ? Qt : Qnil;
757 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
758 Return value for KEY in DATABASE.
759 If there is no corresponding value, return DEFAULT (defaults to nil).
761 (key, database, default_))
763 CHECK_LIVE_DATABASE (database);
766 Lisp_Database *db = XDATABASE (database);
767 Lisp_Object retval = db->funcs->get (db, key);
768 return NILP (retval) ? default_ : retval;
772 DEFUN ("map-database", Fmap_database, 2, 2, 0, /*
773 Map FUNCTION over entries in DATABASE, calling it with two args,
774 each key and value in the database.
776 (function, database))
778 CHECK_LIVE_DATABASE (database);
780 XDATABASE (database)->funcs->map (XDATABASE (database), function);
786 syms_of_database (void)
788 INIT_LRECORD_IMPLEMENTATION (database);
790 defsymbol (&Qdatabasep, "databasep");
792 defsymbol (&Qdbm, "dbm");
794 #ifdef HAVE_BERKELEY_DB
795 defsymbol (&Qberkeley_db, "berkeley-db");
796 defsymbol (&Qhash, "hash");
797 defsymbol (&Qbtree, "btree");
798 defsymbol (&Qrecno, "recno");
799 #if DB_VERSION_MAJOR > 2
800 defsymbol (&Qqueue, "queue");
802 defsymbol (&Qunknown, "unknown");
805 DEFSUBR (Fopen_database);
806 DEFSUBR (Fdatabasep);
807 DEFSUBR (Fmap_database);
808 DEFSUBR (Fput_database);
809 DEFSUBR (Fget_database);
810 DEFSUBR (Fremove_database);
811 DEFSUBR (Fdatabase_type);
812 DEFSUBR (Fdatabase_subtype);
813 DEFSUBR (Fdatabase_last_error);
814 DEFSUBR (Fdatabase_live_p);
815 DEFSUBR (Fdatabase_file_name);
816 DEFSUBR (Fclose_database);
820 vars_of_database (void)
825 #ifdef HAVE_BERKELEY_DB
826 Fprovide (Qberkeley_db);
829 #if 0 /* #### implement me! */
831 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
832 Coding system used to convert data in database files.
834 Vdatabase_coding_system = Qnil;