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 obj)
149 Lisp_Database *db = XDATABASE (obj);
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 (obj, db);
185 ("Can't dump an emacs containing database objects", obj);
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 OBJ is an active database.
233 return DATABASEP (obj) && DATABASE_LIVE_P (XDATABASE (obj)) ? Qt : Qnil;
236 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /*
237 Return the filename associated with the database DATABASE.
241 CHECK_DATABASE (database);
243 return XDATABASE (database)->fname;
246 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /*
247 Return t if OBJ is a database.
251 return DATABASEP (obj) ? Qt : Qnil;
256 dbm_map (Lisp_Database *db, Lisp_Object func)
258 datum keydatum, valdatum;
259 Lisp_Object key, val;
261 for (keydatum = dbm_firstkey (db->dbm_handle);
262 keydatum.dptr != NULL;
263 keydatum = dbm_nextkey (db->dbm_handle))
265 valdatum = dbm_fetch (db->dbm_handle, keydatum);
266 key = make_string ((unsigned char *) keydatum.dptr, keydatum.dsize);
267 val = make_string ((unsigned char *) valdatum.dptr, valdatum.dsize);
268 call2 (func, key, val);
273 dbm_get (Lisp_Database *db, Lisp_Object key)
275 datum keydatum, valdatum;
277 keydatum.dptr = (char *) XSTRING_DATA (key);
278 keydatum.dsize = XSTRING_LENGTH (key);
279 valdatum = dbm_fetch (db->dbm_handle, keydatum);
281 return (valdatum.dptr
282 ? make_string ((unsigned char *) valdatum.dptr, valdatum.dsize)
287 dbm_put (Lisp_Database *db,
288 Lisp_Object key, Lisp_Object val, Lisp_Object replace)
290 datum keydatum, valdatum;
292 valdatum.dptr = (char *) XSTRING_DATA (val);
293 valdatum.dsize = XSTRING_LENGTH (val);
294 keydatum.dptr = (char *) XSTRING_DATA (key);
295 keydatum.dsize = XSTRING_LENGTH (key);
297 return !dbm_store (db->dbm_handle, keydatum, valdatum,
298 NILP (replace) ? DBM_INSERT : DBM_REPLACE);
302 dbm_remove (Lisp_Database *db, Lisp_Object key)
306 keydatum.dptr = (char *) XSTRING_DATA (key);
307 keydatum.dsize = XSTRING_LENGTH (key);
309 return dbm_delete (db->dbm_handle, keydatum);
313 dbm_type (Lisp_Database *db)
319 dbm_subtype (Lisp_Database *db)
325 dbm_lasterr (Lisp_Database *db)
327 return lisp_strerror (db->dberrno);
331 dbm_closeit (Lisp_Database *db)
335 dbm_close (db->dbm_handle);
336 db->dbm_handle = NULL;
340 static DB_FUNCS ndbm_func_block =
351 #endif /* HAVE_DBM */
353 #ifdef HAVE_BERKELEY_DB
355 berkdb_type (Lisp_Database *db)
361 berkdb_subtype (Lisp_Database *db)
366 switch (db->db_handle->type)
368 case DB_BTREE: return Qbtree;
369 case DB_HASH: return Qhash;
370 case DB_RECNO: return Qrecno;
371 default: return Qunknown;
376 berkdb_lasterr (Lisp_Database *db)
378 return lisp_strerror (db->dberrno);
382 berkdb_get (Lisp_Database *db, Lisp_Object key)
384 DBT keydatum, valdatum;
387 /* DB Version 2 requires DBT's to be zeroed before use. */
391 keydatum.data = XSTRING_DATA (key);
392 keydatum.size = XSTRING_LENGTH (key);
394 #if DB_VERSION_MAJOR == 1
395 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0);
397 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0);
398 #endif /* DB_VERSION_MAJOR */
401 /* #### Not mule-ized! will crash! */
402 return make_string ((Bufbyte *) valdatum.data, valdatum.size);
404 #if DB_VERSION_MAJOR == 1
405 db->dberrno = (status == 1) ? -1 : errno;
407 db->dberrno = (status < 0) ? -1 : errno;
408 #endif /* DB_VERSION_MAJOR */
414 berkdb_put (Lisp_Database *db,
419 DBT keydatum, valdatum;
422 /* DB Version 2 requires DBT's to be zeroed before use. */
426 keydatum.data = XSTRING_DATA (key);
427 keydatum.size = XSTRING_LENGTH (key);
428 valdatum.data = XSTRING_DATA (val);
429 valdatum.size = XSTRING_LENGTH (val);
430 #if DB_VERSION_MAJOR == 1
431 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum,
432 NILP (replace) ? R_NOOVERWRITE : 0);
433 db->dberrno = (status == 1) ? -1 : errno;
435 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum,
436 NILP (replace) ? DB_NOOVERWRITE : 0);
437 db->dberrno = (status < 0) ? -1 : errno;
438 #endif/* DV_VERSION_MAJOR = 2 */
444 berkdb_remove (Lisp_Database *db, Lisp_Object key)
449 /* DB Version 2 requires DBT's to be zeroed before use. */
452 keydatum.data = XSTRING_DATA (key);
453 keydatum.size = XSTRING_LENGTH (key);
455 #if DB_VERSION_MAJOR == 1
456 status = db->db_handle->del (db->db_handle, &keydatum, 0);
458 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0);
459 #endif /* DB_VERSION_MAJOR */
464 #if DB_VERSION_MAJOR == 1
465 db->dberrno = (status == 1) ? -1 : errno;
467 db->dberrno = (status < 0) ? -1 : errno;
468 #endif /* DB_VERSION_MAJOR */
474 berkdb_map (Lisp_Database *db, Lisp_Object func)
476 DBT keydatum, valdatum;
477 Lisp_Object key, val;
478 DB *dbp = db->db_handle;
484 #if DB_VERSION_MAJOR == 1
485 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
487 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT))
489 /* #### Needs mule-izing */
490 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
491 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
492 call2 (func, key, val);
498 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6
499 status = dbp->cursor (dbp, NULL, &dbcp, 0);
501 status = dbp->cursor (dbp, NULL, &dbcp);
503 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
505 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT))
507 /* #### Needs mule-izing */
508 key = make_string ((Bufbyte *) keydatum.data, keydatum.size);
509 val = make_string ((Bufbyte *) valdatum.data, valdatum.size);
510 call2 (func, key, val);
512 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 TO_EXTERNAL_FORMAT (LISP_STRING, file,
582 C_STRING_ALLOCA, filename,
587 accessmask = O_RDWR | O_CREAT;
592 CHECK_STRING (access_);
593 acc = (char *) XSTRING_DATA (access_);
595 if (strchr (acc, '+'))
596 accessmask |= O_CREAT;
599 char *rp = strchr (acc, 'r');
600 char *wp = strchr (acc, 'w');
601 if (rp && wp) accessmask |= O_RDWR;
602 else if (wp) accessmask |= O_WRONLY;
603 else accessmask |= O_RDONLY;
609 modemask = 0755; /* rwxr-xr-x */
614 modemask = XINT (mode);
618 if (NILP (type) || EQ (type, Qdbm))
620 DBM *dbase = dbm_open (filename, accessmask, modemask);
624 db = allocate_database ();
625 db->dbm_handle = dbase;
626 db->funcs = &ndbm_func_block;
629 #endif /* HAVE_DBM */
631 #ifdef HAVE_BERKELEY_DB
632 if (NILP (type) || EQ (type, Qberkeley_db))
636 #if DB_VERSION_MAJOR != 1
640 if (EQ (subtype, Qhash) || NILP (subtype))
641 real_subtype = DB_HASH;
642 else if (EQ (subtype, Qbtree))
643 real_subtype = DB_BTREE;
644 else if (EQ (subtype, Qrecno))
645 real_subtype = DB_RECNO;
647 signal_simple_error ("Unsupported subtype", subtype);
649 #if DB_VERSION_MAJOR == 1
650 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL);
654 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY,
655 other flags shouldn't be set */
657 accessmask = DB_CREATE;
661 CHECK_STRING (access_);
662 acc = (char *) XSTRING_DATA (access_);
665 if (strchr (acc, '+'))
666 accessmask |= DB_CREATE;
668 if (strchr (acc, 'r') && !strchr (acc, 'w'))
669 accessmask |= DB_RDONLY;
671 status = db_open (filename, real_subtype, accessmask,
672 modemask, NULL , NULL, &dbase);
675 #endif /* DB_VERSION_MAJOR */
677 db = allocate_database ();
678 db->db_handle = dbase;
679 db->funcs = &berk_func_block;
682 #endif /* HAVE_BERKELEY_DB */
684 signal_simple_error ("Unsupported database type", type);
691 db->access_ = accessmask;
695 XSETDATABASE (retval, db);
700 DEFUN ("put-database", Fput_database, 3, 4, 0, /*
701 Store KEY and VALUE in DATABASE.
702 If optional fourth arg REPLACE is non-nil,
703 replace any existing entry in the database.
705 (key, value, database, replace))
707 CHECK_LIVE_DATABASE (database);
709 CHECK_STRING (value);
711 Lisp_Database *db = XDATABASE (database);
712 int status = db->funcs->put (db, key, value, replace);
713 return status ? Qt : Qnil;
717 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /*
718 Remove KEY from DATABASE.
722 CHECK_LIVE_DATABASE (database);
725 Lisp_Database *db = XDATABASE (database);
726 int status = db->funcs->rem (db, key);
727 return status ? Qt : Qnil;
731 DEFUN ("get-database", Fget_database, 2, 3, 0, /*
732 Return value for KEY in DATABASE.
733 If there is no corresponding value, return DEFAULT (defaults to nil).
735 (key, database, default_))
737 CHECK_LIVE_DATABASE (database);
740 Lisp_Database *db = XDATABASE (database);
741 Lisp_Object retval = db->funcs->get (db, key);
742 return NILP (retval) ? default_ : retval;
746 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /*
747 Map FUNCTION over entries in DATABASE, calling it with two args,
748 each key and value in the database.
750 (function, database))
752 CHECK_LIVE_DATABASE (database);
754 XDATABASE (database)->funcs->map (XDATABASE (database), function);
760 syms_of_database (void)
762 INIT_LRECORD_IMPLEMENTATION (database);
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;