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 #ifndef __BIT_TYPES_DEFINED__
47 #define __BIT_TYPES_DEFINED__
51 typedef uint8_t u_int8_t;
54 typedef uint16_t u_int16_t;
57 typedef uint32_t u_int32_t;
59 #ifdef WE_DONT_NEED_QUADS
61 typedef uint64_t u_int64_t;
63 #endif /* WE_DONT_NEED_QUADS */
64 #endif /* HAVE_INTTYPES_H */
65 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */
66 /* Berkeley DB wants __STDC__ to be defined; else if does `#define const' */
67 #if ! defined (__STDC__) && ! defined(__cplusplus)
70 #include DB_H_FILE /* Berkeley db's header file */
71 #ifndef DB_VERSION_MAJOR
72 # define DB_VERSION_MAJOR 1
73 #endif /* DB_VERSION_MAJOR */
74 #ifndef DB_VERSION_MINOR
75 # define DB_VERSION_MINOR 0
76 #endif /* DB_VERSION_MINOR */
77 Lisp_Object Qberkeley_db;
78 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown;
79 #if DB_VERSION_MAJOR > 2
82 #endif /* HAVE_BERKELEY_DB */
90 /* #### The following should be settable on a per-database level.
91 But the whole coding-system infrastructure should be rewritten someday.
92 We really need coding-system aliases. -- martin */
93 Lisp_Object Vdatabase_coding_system;
96 Lisp_Object Qdatabasep;
100 Lisp_Object (*get_subtype) (Lisp_Database *);
101 Lisp_Object (*get_type) (Lisp_Database *);
102 Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
103 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
104 int (*rem) (Lisp_Database *, Lisp_Object);
105 void (*map) (Lisp_Database *, Lisp_Object);
106 void (*close) (Lisp_Database *);
107 Lisp_Object (*last_error) (Lisp_Database *);
112 struct lcrecord_header header;
121 #ifdef HAVE_BERKELEY_DB
126 Lisp_Object coding_system;
130 #define XDATABASE(x) XRECORD (x, database, Lisp_Database)
131 #define XSETDATABASE(x, p) XSETRECORD (x, p, database)
132 #define DATABASEP(x) RECORDP (x, database)
133 #define CHECK_DATABASE(x) CHECK_RECORD (x, database)
134 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database)
135 #define DATABASE_LIVE_P(x) (x->live_p)
137 #define CHECK_LIVE_DATABASE(db) do { \
138 CHECK_DATABASE (db); \
139 if (!DATABASE_LIVE_P (XDATABASE(db))) \
140 signal_simple_error ("Attempting to access closed database", db); \
144 static Lisp_Database *
145 allocate_database (void)
147 Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, &lrecord_database);
151 #ifdef HAVE_BERKELEY_DB
152 db->db_handle = NULL;
155 db->dbm_handle = NULL;
161 db->coding_system = Fget_coding_system (Qbinary);
167 mark_database (Lisp_Object object)
169 Lisp_Database *db = XDATABASE (object);
174 print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
177 Lisp_Database *db = XDATABASE (obj);
180 error ("printing unreadable object #<database 0x%x>", db->header.uid);
182 write_c_string ("#<database \"", printcharfun);
183 print_internal (db->fname, printcharfun, 0);
184 sprintf (buf, "\" (%s/%s/%s) 0x%x>",
185 (char *) string_data (XSYMBOL (db->funcs->get_type (db))->name),
186 (char *) string_data (XSYMBOL (db->funcs->get_subtype (db))->name),
187 (!DATABASE_LIVE_P (db) ? "closed" :
188 (db->access_ & O_WRONLY) ? "writeonly" :
189 (db->access_ & O_RDWR) ? "readwrite" : "readonly"),
191 write_c_string (buf, printcharfun);
195 finalize_database (void *header, int for_disksave)
197 Lisp_Database *db = (Lisp_Database *) header;
202 XSETDATABASE (object, db);
205 ("Can't dump an emacs containing database objects", object);
207 db->funcs->close (db);
210 DEFINE_LRECORD_IMPLEMENTATION ("database", database,
211 mark_database, print_database,
212 finalize_database, 0, 0, 0,
215 DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
216 Close database DATABASE.
221 CHECK_LIVE_DATABASE (database);
222 db = XDATABASE (database);
223 db->funcs->close (db);
228 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /*
229 Return the type of database DATABASE.
233 CHECK_DATABASE (database);
235 return XDATABASE (database)->funcs->get_type (XDATABASE (database));
238 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /*
239 Return the subtype of database DATABASE, if any.
243 CHECK_DATABASE (database);
245 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database));
248 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /*
249 Return t if OBJECT is an active database.
253 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ?
257 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
258 Return the filename associated with the database DATABASE.
262 CHECK_DATABASE (database);
264 return XDATABASE (database)->fname;
267 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
268 Return t if OBJECT is a database.
272 return DATABASEP (object) ? Qt : Qnil;
277 dbm_map (Lisp_Database *db, Lisp_Object func)
279 datum keydatum, valdatum;
280 Lisp_Object key, val;
282 for (keydatum = dbm_firstkey (db->dbm_handle);
283 keydatum.dptr != NULL;
284 keydatum = dbm_nextkey (db->dbm_handle))
286 valdatum = dbm_fetch (db->dbm_handle, keydatum);
287 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
288 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
289 call2 (func, key, val);
294 dbm_get (Lisp_Database *db, Lisp_Object key)
296 datum keydatum, valdatum;
298 keydatum.dptr = (char *) XSTRING_DATA (key);
299 keydatum.dsize = XSTRING_LENGTH (key);
300 valdatum = dbm_fetch (db->dbm_handle, keydatum);
302 return (valdatum.dptr
303 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
308 dbm_put (Lisp_Database *db,
309 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
311 datum keydatum, valdatum;
313 valdatum.dptr = (char *) XSTRING_DATA (val);
314 valdatum.dsize = XSTRING_LENGTH (val);
315 keydatum.dptr = (char *) XSTRING_DATA (key);
316 keydatum.dsize = XSTRING_LENGTH (key);
318 return !dbm_store (db->dbm_handle, keydatum, valdatum,
319 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
323 dbm_remove (Lisp_Database *db, Lisp_Object key)
327 keydatum.dptr = (char *) XSTRING_DATA (key);
328 keydatum.dsize = XSTRING_LENGTH (key);
330 return dbm_delete (db->dbm_handle, keydatum);
334 dbm_type (Lisp_Database *db)
340 dbm_subtype (Lisp_Database *db)
346 dbm_lasterr (Lisp_Database *db)
348 return lisp_strerror (db->dberrno);
352 dbm_closeit (Lisp_Database *db)
356 dbm_close (db->dbm_handle);
357 db->dbm_handle = NULL;
361 static DB_FUNCS ndbm_func_block =
372 #endif /* HAVE_DBM */
374 #ifdef HAVE_BERKELEY_DB
376 berkdb_type (Lisp_Database *db)
382 berkdb_subtype (Lisp_Database *db)
387 switch (db->db_handle->type)
389 case DB_BTREE: return Qbtree;
390 case DB_HASH: return Qhash;
391 case DB_RECNO: return Qrecno;
392 #if DB_VERSION_MAJOR > 2
393 case DB_QUEUE: return Qqueue;
395 default: return Qunknown;
400 berkdb_lasterr (Lisp_Database *db)
402 return lisp_strerror (db->dberrno);
406 berkdb_get (Lisp_Database *db, Lisp_Object key)
408 DBT keydatum, valdatum;
411 /* DB Version 2 requires DBT's to be zeroed before use. */
415 keydatum.data = XSTRING_DATA (key);
416 keydatum.size = XSTRING_LENGTH (key);
418 #if DB_VERSION_MAJOR == 1
419 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
421 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
422 #endif /* DB_VERSION_MAJOR */
425 /* #### Not mule-ized! will crash! */
426 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
428 #if DB_VERSION_MAJOR == 1
429 db->dberrno = (status == 1) ? -1 : errno;
431 db->dberrno = (status < 0) ? -1 : errno;
432 #endif /* DB_VERSION_MAJOR */
438 berkdb_put (Lisp_Database *db,
443 DBT keydatum, valdatum;
446 /* DB Version 2 requires DBT's to be zeroed before use. */
450 keydatum.data = XSTRING_DATA (key);
451 keydatum.size = XSTRING_LENGTH (key);
452 valdatum.data = XSTRING_DATA (val);
453 valdatum.size = XSTRING_LENGTH (val);
454 #if DB_VERSION_MAJOR == 1
455 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
456 NILP (replace) ? R_NOOVERWRITE : 0);
457 db->dberrno = (status == 1) ? -1 : errno;
459 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
460 NILP (replace) ? DB_NOOVERWRITE : 0);
461 db->dberrno = (status < 0) ? -1 : errno;
462 #endif/* DV_VERSION_MAJOR = 2 */
468 berkdb_remove (Lisp_Database *db, Lisp_Object key)
473 /* DB Version 2 requires DBT's to be zeroed before use. */
476 keydatum.data = XSTRING_DATA (key);
477 keydatum.size = XSTRING_LENGTH (key);
479 #if DB_VERSION_MAJOR == 1
480 status = db->db_handle->del (db->db_handle, &keydatum, 0);
482 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
483 #endif /* DB_VERSION_MAJOR */
488 #if DB_VERSION_MAJOR == 1
489 db->dberrno = (status == 1) ? -1 : errno;
491 db->dberrno = (status < 0) ? -1 : errno;
492 #endif /* DB_VERSION_MAJOR */
498 berkdb_map (Lisp_Database *db, Lisp_Object func)
500 DBT keydatum, valdatum;
501 Lisp_Object key, val;
502 DB *dbp = db->db_handle;
508 #if DB_VERSION_MAJOR == 1
509 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
511 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
513 /* #### Needs mule-izing */
514 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
515 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
516 call2 (func, key, val);
522 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
523 status = dbp->cursor (dbp, NULL, &dbcp, 0);
525 status = dbp->cursor (dbp, NULL, &dbcp);
527 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
529 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
531 /* #### Needs mule-izing */
532 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
533 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
534 call2 (func, key, val);
536 dbcp->c_close (dbcp);
538 #endif /* DB_VERSION_MAJOR */
542 berkdb_close (Lisp_Database *db)
546 #if DB_VERSION_MAJOR == 1
547 db->db_handle->sync (db->db_handle, 0);
548 db->db_handle->close (db->db_handle);
550 db->db_handle->sync (db->db_handle, 0);
551 db->db_handle->close (db->db_handle, 0);
552 #endif /* DB_VERSION_MAJOR */
553 db->db_handle = NULL;
557 static DB_FUNCS berk_func_block =
568 #endif /* HAVE_BERKELEY_DB */
570 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /*
571 Return the last error associated with DATABASE.
576 return lisp_strerror (errno);
578 CHECK_DATABASE (database);
580 return XDATABASE (database)->funcs->last_error (XDATABASE (database));
583 DEFUN ("open-database", Fopen_database, 1, 5, 0, /*
584 Return a new database object opened on FILE.
585 Optional arguments TYPE and SUBTYPE specify the database type.
586 Optional argument ACCESS specifies the access rights, which may be any
587 combination of 'r' 'w' and '+', for read, write, and creation flags.
588 Optional argument MODE gives the permissions to use when opening FILE,
589 and defaults to 0755.
591 (file, type, subtype, access_, mode))
593 /* This function can GC */
596 Lisp_Database *db = NULL;
598 struct gcpro gcpro1, gcpro2;
601 GCPRO2 (file, access_);
602 file = Fexpand_file_name (file, Qnil);
605 TO_EXTERNAL_FORMAT (LISP_STRING, file,
606 C_STRING_ALLOCA, filename,
611 accessmask = O_RDWR | O_CREAT;
616 CHECK_STRING (access_);
617 acc = (char *) XSTRING_DATA (access_);
619 if (strchr (acc, '+'))
620 accessmask |= O_CREAT;
623 char *rp = strchr (acc, 'r');
624 char *wp = strchr (acc, 'w');
625 if (rp && wp) accessmask |= O_RDWR;
626 else if (wp) accessmask |= O_WRONLY;
627 else accessmask |= O_RDONLY;
633 modemask = 0755; /* rwxr-xr-x */
638 modemask = XINT (mode);
642 if (NILP (type) || EQ (type, Qdbm))
644 DBM *dbase = dbm_open (filename, accessmask, modemask);
648 db = allocate_database ();
649 db->dbm_handle = dbase;
650 db->funcs = &ndbm_func_block;
653 #endif /* HAVE_DBM */
655 #ifdef HAVE_BERKELEY_DB
656 if (NILP (type) || EQ (type, Qberkeley_db))
660 #if DB_VERSION_MAJOR != 1
664 if (EQ (subtype, Qhash) || NILP (subtype))
665 real_subtype = DB_HASH;
666 else if (EQ (subtype, Qbtree))
667 real_subtype = DB_BTREE;
668 else if (EQ (subtype, Qrecno))
669 real_subtype = DB_RECNO;
670 #if DB_VERSION_MAJOR > 2
671 else if (EQ (subtype, Qqueue))
672 real_subtype = DB_QUEUE;
675 signal_simple_error ("Unsupported subtype", subtype);
677 #if DB_VERSION_MAJOR == 1
678 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
682 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
683 other flags shouldn't be set */
685 accessmask = DB_CREATE;
689 CHECK_STRING (access_);
690 acc = (char *) XSTRING_DATA (access_);
693 if (strchr (acc, '+'))
694 accessmask |= DB_CREATE;
696 if (strchr (acc, 'r') && !strchr (acc, 'w'))
697 accessmask |= DB_RDONLY;
699 #if DB_VERSION_MAJOR == 2
700 status = db_open (filename, real_subtype, accessmask,
701 modemask, NULL , NULL, &dbase);
705 status = db_create (&dbase, NULL, 0);
708 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1)
709 status = dbase->open (dbase, filename, NULL,
710 real_subtype, accessmask, modemask);
711 #else /* DB_VERSION >= 4.1 */
712 /* DB_AUTO_COMMIT requires transaction support, don't try it */
713 status = dbase->open (dbase, NULL, filename, NULL, real_subtype,
714 accessmask, modemask);
715 #endif /* DB_VERSION < 4.1 */
718 dbase->close (dbase, 0);
721 #endif /* DB_VERSION_MAJOR > 2 */
722 /* Normalize into system specific file modes. Only for printing */
723 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR;
724 #endif /* DB_VERSION_MAJOR */
726 db = allocate_database ();
727 db->db_handle = dbase;
728 db->funcs = &berk_func_block;
731 #endif /* HAVE_BERKELEY_DB */
733 signal_simple_error ("Unsupported database type", type);
740 db->access_ = accessmask;
744 XSETDATABASE (retval, db);
749 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
750 Store KEY and VALUE in DATABASE.
751 If optional fourth arg REPLACE is non-nil,
752 replace any existing entry in the database.
754 (key, value, database, replace))
756 CHECK_LIVE_DATABASE (database);
758 CHECK_STRING (value);
760 Lisp_Database *db = XDATABASE (database);
761 int status = db->funcs->put (db, key, value, replace);
762 return status ? Qt : Qnil;
766 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
767 Remove KEY from DATABASE.
771 CHECK_LIVE_DATABASE (database);
774 Lisp_Database *db = XDATABASE (database);
775 int status = db->funcs->rem (db, key);
776 return status ? Qt : Qnil;
780 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
781 Return value for KEY in DATABASE.
782 If there is no corresponding value, return DEFAULT (defaults to nil).
784 (key, database, default_))
786 CHECK_LIVE_DATABASE (database);
789 Lisp_Database *db = XDATABASE (database);
790 Lisp_Object retval = db->funcs->get (db, key);
791 return NILP (retval) ? default_ : retval;
795 DEFUN ("map-database", Fmap_database, 2, 2, 0, /*
796 Map FUNCTION over entries in DATABASE, calling it with two args,
797 each key and value in the database.
799 (function, database))
801 CHECK_LIVE_DATABASE (database);
803 XDATABASE (database)->funcs->map (XDATABASE (database), function);
809 syms_of_database (void)
811 INIT_LRECORD_IMPLEMENTATION (database);
813 defsymbol (&Qdatabasep, "databasep");
815 defsymbol (&Qdbm, "dbm");
817 #ifdef HAVE_BERKELEY_DB
818 defsymbol (&Qberkeley_db, "berkeley-db");
819 defsymbol (&Qhash, "hash");
820 defsymbol (&Qbtree, "btree");
821 defsymbol (&Qrecno, "recno");
822 #if DB_VERSION_MAJOR > 2
823 defsymbol (&Qqueue, "queue");
825 defsymbol (&Qunknown, "unknown");
828 DEFSUBR (Fopen_database);
829 DEFSUBR (Fdatabasep);
830 DEFSUBR (Fmap_database);
831 DEFSUBR (Fput_database);
832 DEFSUBR (Fget_database);
833 DEFSUBR (Fremove_database);
834 DEFSUBR (Fdatabase_type);
835 DEFSUBR (Fdatabase_subtype);
836 DEFSUBR (Fdatabase_last_error);
837 DEFSUBR (Fdatabase_live_p);
838 DEFSUBR (Fdatabase_file_name);
839 DEFSUBR (Fclose_database);
843 vars_of_database (void)
848 #ifdef HAVE_BERKELEY_DB
849 Fprovide (Qberkeley_db);
852 #if 0 /* #### implement me! */
854 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
855 Coding system used to convert data in database files.
857 Vdatabase_coding_system = Qnil;