Mercurial > hg > xemacs-beta
annotate src/database.c @ 5142:f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Working with Lisp Objects):
* internals/internals.texi (Writing Macros):
* internals/internals.texi (lrecords):
More rewriting to correspond with changes from
*LRECORD* to *LISP_OBJECT*.
modules/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (print_pgconn):
* postgresql/postgresql.c (print_pgresult):
printing_unreadable_object -> printing_unreadable_object_fmt.
2010-03-13 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
printing_unreadable_object -> printing_unreadable_object_fmt.
src/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* alloc.c (alloc_sized_lrecord_1):
* alloc.c (alloc_sized_lrecord_array):
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (tick_lcrecord_stats):
* alloc.c (sweep_lcrecords_1):
* buffer.c (print_buffer):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* casetab.c:
* casetab.c (print_case_table):
* console.c (print_console):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* data.c (print_weak_list):
* data.c (print_weak_box):
* data.c (print_ephemeron):
* data.c (ephemeron_equal):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_subr):
* eval.c (print_multiple_value):
* event-stream.c (event_stream_resignal_wakeup):
* events.c (clear_event_resource):
* events.c (zero_event):
* events.c (print_event):
* extents.c:
* extents.c (print_extent):
* file-coding.c (print_coding_system):
* font-mgr.c:
* font-mgr.c (Ffc_init):
* frame.c:
* frame.c (print_frame):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c (print_gui_item):
* gui.c (copy_gui_item):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lisp.h (struct Lisp_String):
* lisp.h (DEFUN):
* lisp.h (DEFUN_NORETURN):
* lrecord.h:
* lrecord.h (NORMAL_LISP_OBJECT_UID):
* lrecord.h (struct lrecord_header):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lrecord.h (struct free_lcrecord_header):
* marker.c (print_marker):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* print.c (print_cons):
* print.c (printing_unreadable_object_fmt):
* print.c (printing_unreadable_lisp_object):
* print.c (external_object_printer):
* print.c (internal_object_printer):
* print.c (debug_p4):
* print.c (ext_print_begin):
* process.c (print_process):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* scrollbar.c (free_scrollbar_instance):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c (guts_of_unbound_marker):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* ui-gtk.c (ffi_object_printer):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* window.c (print_window):
* window.c (free_window_mirror):
* window.c (debug_print_window):
* xemacs.def.in.in:
(1) printing_unreadable_object -> printing_unreadable_object_fmt.
(2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object
and fix up so it no longer requires an lcrecord.
These previous changes eliminate most of the remaining places where
the terms `lcrecord' and `lrecord' occurred outside of specialized
code.
(3) Fairly major change: Reduce the number of words in an lcrecord
from 3 to 2. The third word consisted of a uid that duplicated the
lrecord uid, and a single free bit, which was moved into the lrecord
structure. This reduces the size of the `uid' slot from 21 bits to
20 bits. Arguably this isn't enough -- we could easily have more than
1,000,000 or so objects created in a session. The answer is
(a) It doesn't really matter if we overflow the uid field because
it's only used for debugging, to identify an object uniquely
(or pretty much so).
(b) If we cared about it overflowing and wanted to reduce this,
we could make it so that cons, string, float and certain other
frob-block types that never print out the uid simply don't
store a uid in them and don't increment the lrecord_uid_counter.
(4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID()
and use it to abstract out the differences between NEWGC and old-GC
in accessing the `uid' value from a "normal Lisp Object pointer".
(5) In events.c, use zero_nonsized_lisp_object() in place of custom-
written equivalent. In font-mgr.c use external_object_printer()
in place of custom-written equivalents.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sat, 13 Mar 2010 05:38:08 -0600 |
parents | a9c41067dd88 |
children | 88bd4f3ef8e4 |
rev | line source |
---|---|
428 | 1 /* Database access routines |
2 Copyright (C) 1996, William M. Perry | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3 Copyright (C) 2001, 2002, 2005, 2010 Ben Wing. |
428 | 4 |
5 This file is part of XEmacs. | |
6 | |
7 XEmacs is free software; you can redistribute it and/or modify it | |
8 under the terms of the GNU General Public License as published by the | |
9 Free Software Foundation; either version 2, or (at your option) any | |
10 later version. | |
11 | |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with XEmacs; see the file COPYING. If not, write to | |
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 Boston, MA 02111-1307, USA. */ | |
21 | |
22 /* Synched up with: Not in FSF. */ | |
23 | |
24 /* Written by Bill Perry */ | |
25 /* Substantially rewritten by Martin Buchholz */ | |
26 /* db 2.x support added by Andreas Jaeger */ | |
771 | 27 /* Mule-ized 6-22-00 Ben Wing */ |
428 | 28 |
29 #include <config.h> | |
30 #include "lisp.h" | |
771 | 31 |
428 | 32 #include "sysfile.h" |
33 #include "buffer.h" | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
34 #include "file-coding.h" |
428 | 35 |
36 #ifndef HAVE_DATABASE | |
37 #error HAVE_DATABASE not defined!! | |
38 #endif | |
39 | |
40 #include "database.h" /* Our include file */ | |
41 | |
42 #ifdef HAVE_BERKELEY_DB | |
43 /* Work around Berkeley DB's use of int types which are defined | |
44 slightly differently in the not quite yet standard <inttypes.h>. | |
45 See db.h for details of why we're resorting to this... */ | |
46 /* glibc 2.1 doesn't have this problem with DB 2.x */ | |
47 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) | |
48 #ifdef HAVE_INTTYPES_H | |
3739 | 49 #ifndef __BIT_TYPES_DEFINED__ |
428 | 50 #define __BIT_TYPES_DEFINED__ |
3739 | 51 #endif |
428 | 52 #include <inttypes.h> |
3739 | 53 #if !HAVE_U_INT8_T |
428 | 54 typedef uint8_t u_int8_t; |
3739 | 55 #endif |
56 #if !HAVE_U_INT16_T | |
428 | 57 typedef uint16_t u_int16_t; |
3739 | 58 #endif |
59 #if !HAVE_U_INT32_T | |
428 | 60 typedef uint32_t u_int32_t; |
3739 | 61 #endif |
428 | 62 #ifdef WE_DONT_NEED_QUADS |
3739 | 63 #if !HAVE_U_INT64_T |
428 | 64 typedef uint64_t u_int64_t; |
3739 | 65 #endif |
428 | 66 #endif /* WE_DONT_NEED_QUADS */ |
67 #endif /* HAVE_INTTYPES_H */ | |
68 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */ | |
1460 | 69 /* Berkeley DB wants __STDC__ to be defined; else if does `#define const' */ |
70 #if ! defined (__STDC__) && ! defined(__cplusplus) | |
71 #define __STDC__ 0 | |
72 #endif | |
442 | 73 #include DB_H_FILE /* Berkeley db's header file */ |
428 | 74 #ifndef DB_VERSION_MAJOR |
75 # define DB_VERSION_MAJOR 1 | |
76 #endif /* DB_VERSION_MAJOR */ | |
1141 | 77 #ifndef DB_VERSION_MINOR |
78 # define DB_VERSION_MINOR 0 | |
79 #endif /* DB_VERSION_MINOR */ | |
428 | 80 Lisp_Object Qberkeley_db; |
81 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown; | |
448 | 82 #if DB_VERSION_MAJOR > 2 |
83 Lisp_Object Qqueue; | |
84 #endif | |
428 | 85 #endif /* HAVE_BERKELEY_DB */ |
86 | |
87 #ifdef HAVE_DBM | |
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
88 # ifdef TRUST_NDBM_H_PROTOTYPES |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
89 # include NDBM_H_FILE |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
90 # else /* not TRUST_NDBM_H_PROTOTYPES */ |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
91 |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
92 /* The prototypes in gdbm/ndbm.h currently are broken when compiling |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
93 using C++, since they are of the form `datum dbm_firstkey()', without any |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
94 args given. */ |
4824
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
95 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
96 #if defined(__cplusplus) || defined(c_plusplus) |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
97 extern "C" { |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
98 #endif |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
99 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
100 /* Parameters to dbm_store for simple insertion or replacement. */ |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
101 #define DBM_INSERT 0 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
102 #define DBM_REPLACE 1 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
103 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
104 /* The data and key structure. This structure is defined for compatibility. */ |
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
105 typedef struct |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
106 { |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
107 char *dptr; |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
108 int dsize; |
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
109 } datum; |
4824
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
110 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
111 /* The file information header. This is good enough for most applications. */ |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
112 typedef struct {int dummy[10];} DBM; |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
113 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
114 int dbm_clearerr(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
115 void dbm_close(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
116 int dbm_delete(DBM *, datum); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
117 int dbm_error(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
118 datum dbm_fetch(DBM *, datum); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
119 datum dbm_firstkey(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
120 datum dbm_nextkey(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
121 DBM *dbm_open(const char *, int, mode_t); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
122 int dbm_store(DBM *, datum, datum, int); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
123 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
124 #if defined(__cplusplus) || defined(c_plusplus) |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
125 } |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
126 #endif |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
127 |
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
128 # endif /* (not) TRUST_NDBM_H_PROTOTYPES */ |
428 | 129 Lisp_Object Qdbm; |
130 #endif /* HAVE_DBM */ | |
131 | |
132 Lisp_Object Vdatabase_coding_system; | |
133 | |
134 Lisp_Object Qdatabasep; | |
135 | |
136 typedef struct | |
137 { | |
138 Lisp_Object (*get_subtype) (Lisp_Database *); | |
139 Lisp_Object (*get_type) (Lisp_Database *); | |
140 Lisp_Object (*get) (Lisp_Database *, Lisp_Object); | |
141 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); | |
142 int (*rem) (Lisp_Database *, Lisp_Object); | |
143 void (*map) (Lisp_Database *, Lisp_Object); | |
144 void (*close) (Lisp_Database *); | |
145 Lisp_Object (*last_error) (Lisp_Database *); | |
146 } DB_FUNCS; | |
147 | |
148 struct Lisp_Database | |
149 { | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
150 NORMAL_LISP_OBJECT_HEADER header; |
428 | 151 Lisp_Object fname; |
152 int mode; | |
153 int access_; | |
154 int dberrno; | |
155 int live_p; | |
156 #ifdef HAVE_DBM | |
157 DBM *dbm_handle; | |
158 #endif | |
159 #ifdef HAVE_BERKELEY_DB | |
160 DB *db_handle; | |
161 #endif | |
162 DB_FUNCS *funcs; | |
163 Lisp_Object coding_system; | |
164 }; | |
165 | |
166 #define XDATABASE(x) XRECORD (x, database, Lisp_Database) | |
617 | 167 #define wrap_database(p) wrap_record (p, database) |
428 | 168 #define DATABASEP(x) RECORDP (x, database) |
169 #define CHECK_DATABASE(x) CHECK_RECORD (x, database) | |
170 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database) | |
171 #define DATABASE_LIVE_P(x) (x->live_p) | |
172 | |
173 #define CHECK_LIVE_DATABASE(db) do { \ | |
174 CHECK_DATABASE (db); \ | |
175 if (!DATABASE_LIVE_P (XDATABASE(db))) \ | |
563 | 176 invalid_operation ("Attempting to access closed database", db); \ |
428 | 177 } while (0) |
178 | |
179 | |
180 static Lisp_Database * | |
181 allocate_database (void) | |
182 { | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
183 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (database); |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
184 Lisp_Database *db = XDATABASE (obj); |
428 | 185 |
186 db->fname = Qnil; | |
187 db->live_p = 0; | |
188 #ifdef HAVE_BERKELEY_DB | |
189 db->db_handle = NULL; | |
190 #endif | |
191 #ifdef HAVE_DBM | |
192 db->dbm_handle = NULL; | |
193 #endif | |
194 db->access_ = 0; | |
195 db->mode = 0; | |
196 db->dberrno = 0; | |
771 | 197 db->coding_system = Qnil; |
428 | 198 return db; |
199 } | |
200 | |
1204 | 201 static const struct memory_description database_description[] = { |
934 | 202 { XD_LISP_OBJECT, offsetof (struct Lisp_Database, fname) }, |
203 { XD_END} | |
204 }; | |
205 | |
428 | 206 static Lisp_Object |
444 | 207 mark_database (Lisp_Object object) |
428 | 208 { |
444 | 209 Lisp_Database *db = XDATABASE (object); |
428 | 210 return db->fname; |
211 } | |
212 | |
213 static void | |
2286 | 214 print_database (Lisp_Object obj, Lisp_Object printcharfun, |
215 int UNUSED (escapeflag)) | |
428 | 216 { |
217 Lisp_Database *db = XDATABASE (obj); | |
218 | |
219 if (print_readably) | |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
220 printing_unreadable_lisp_object (obj, 0); |
428 | 221 |
793 | 222 write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", |
223 3, db->fname, db->funcs->get_type (db), | |
224 db->funcs->get_subtype (db)); | |
225 | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
226 write_fmt_string (printcharfun, "%s) ", |
793 | 227 (!DATABASE_LIVE_P (db) ? "closed" : |
228 (db->access_ & O_WRONLY) ? "writeonly" : | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
229 (db->access_ & O_RDWR) ? "readwrite" : "readonly")); |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
230 |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
231 write_fmt_string_lisp (printcharfun, "coding: %s ", 1, |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
232 XSYMBOL_NAME (XCODING_SYSTEM_NAME |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
233 (db->coding_system))); |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
234 |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
235 write_fmt_string (printcharfun, "0x%x>", NORMAL_LISP_OBJECT_UID (db)); |
428 | 236 } |
237 | |
238 static void | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
239 finalize_database (Lisp_Object obj) |
428 | 240 { |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
241 Lisp_Database *db = XDATABASE (obj); |
428 | 242 |
243 db->funcs->close (db); | |
244 } | |
245 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
246 DEFINE_NODUMP_LISP_OBJECT ("database", database, |
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
247 mark_database, print_database, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
248 finalize_database, 0, 0, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
249 database_description, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
250 Lisp_Database); |
428 | 251 |
252 DEFUN ("close-database", Fclose_database, 1, 1, 0, /* | |
253 Close database DATABASE. | |
254 */ | |
255 (database)) | |
256 { | |
257 Lisp_Database *db; | |
258 CHECK_LIVE_DATABASE (database); | |
259 db = XDATABASE (database); | |
260 db->funcs->close (db); | |
261 db->live_p = 0; | |
262 return Qnil; | |
263 } | |
264 | |
265 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /* | |
266 Return the type of database DATABASE. | |
267 */ | |
268 (database)) | |
269 { | |
270 CHECK_DATABASE (database); | |
271 | |
272 return XDATABASE (database)->funcs->get_type (XDATABASE (database)); | |
273 } | |
274 | |
275 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /* | |
276 Return the subtype of database DATABASE, if any. | |
277 */ | |
278 (database)) | |
279 { | |
280 CHECK_DATABASE (database); | |
281 | |
282 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database)); | |
283 } | |
284 | |
285 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /* | |
444 | 286 Return t if OBJECT is an active database. |
428 | 287 */ |
444 | 288 (object)) |
428 | 289 { |
444 | 290 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ? |
291 Qt : Qnil; | |
428 | 292 } |
293 | |
294 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /* | |
295 Return the filename associated with the database DATABASE. | |
296 */ | |
297 (database)) | |
298 { | |
299 CHECK_DATABASE (database); | |
300 | |
301 return XDATABASE (database)->fname; | |
302 } | |
303 | |
304 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /* | |
444 | 305 Return t if OBJECT is a database. |
428 | 306 */ |
444 | 307 (object)) |
428 | 308 { |
444 | 309 return DATABASEP (object) ? Qt : Qnil; |
428 | 310 } |
311 | |
312 #ifdef HAVE_DBM | |
313 static void | |
314 dbm_map (Lisp_Database *db, Lisp_Object func) | |
315 { | |
316 datum keydatum, valdatum; | |
317 Lisp_Object key, val; | |
318 | |
319 for (keydatum = dbm_firstkey (db->dbm_handle); | |
320 keydatum.dptr != NULL; | |
321 keydatum = dbm_nextkey (db->dbm_handle)) | |
322 { | |
323 valdatum = dbm_fetch (db->dbm_handle, keydatum); | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
324 key = make_extstring ((Extbyte *) keydatum.dptr, keydatum.dsize, |
771 | 325 db->coding_system); |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
326 val = make_extstring ((Extbyte *) valdatum.dptr, valdatum.dsize, |
771 | 327 db->coding_system); |
428 | 328 call2 (func, key, val); |
329 } | |
330 } | |
331 | |
332 static Lisp_Object | |
333 dbm_get (Lisp_Database *db, Lisp_Object key) | |
334 { | |
335 datum keydatum, valdatum; | |
336 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
337 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.dptr, keydatum.dsize, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
338 db->coding_system); |
428 | 339 valdatum = dbm_fetch (db->dbm_handle, keydatum); |
340 | |
341 return (valdatum.dptr | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
342 ? make_extstring ((Extbyte *) valdatum.dptr, valdatum.dsize, |
771 | 343 db->coding_system) |
428 | 344 : Qnil); |
345 } | |
346 | |
347 static int | |
348 dbm_put (Lisp_Database *db, | |
349 Lisp_Object key, Lisp_Object val, Lisp_Object replace) | |
350 { | |
351 datum keydatum, valdatum; | |
352 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
353 LISP_STRING_TO_SIZED_EXTERNAL (val, valdatum.dptr, valdatum.dsize, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
354 db->coding_system); |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
355 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.dptr, keydatum.dsize, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
356 db->coding_system); |
428 | 357 |
358 return !dbm_store (db->dbm_handle, keydatum, valdatum, | |
359 NILP (replace) ? DBM_INSERT : DBM_REPLACE); | |
360 } | |
361 | |
362 static int | |
363 dbm_remove (Lisp_Database *db, Lisp_Object key) | |
364 { | |
365 datum keydatum; | |
366 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
367 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.dptr, keydatum.dsize, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
368 db->coding_system); |
428 | 369 |
370 return dbm_delete (db->dbm_handle, keydatum); | |
371 } | |
372 | |
373 static Lisp_Object | |
2494 | 374 dbm_type (Lisp_Database *UNUSED (db)) |
428 | 375 { |
376 return Qdbm; | |
377 } | |
378 | |
379 static Lisp_Object | |
2494 | 380 dbm_subtype (Lisp_Database *UNUSED (db)) |
428 | 381 { |
382 return Qnil; | |
383 } | |
384 | |
385 static Lisp_Object | |
386 dbm_lasterr (Lisp_Database *db) | |
387 { | |
388 return lisp_strerror (db->dberrno); | |
389 } | |
390 | |
391 static void | |
392 dbm_closeit (Lisp_Database *db) | |
393 { | |
394 if (db->dbm_handle) | |
395 { | |
396 dbm_close (db->dbm_handle); | |
397 db->dbm_handle = NULL; | |
398 } | |
399 } | |
400 | |
401 static DB_FUNCS ndbm_func_block = | |
402 { | |
403 dbm_subtype, | |
404 dbm_type, | |
405 dbm_get, | |
406 dbm_put, | |
407 dbm_remove, | |
408 dbm_map, | |
409 dbm_closeit, | |
410 dbm_lasterr | |
411 }; | |
412 #endif /* HAVE_DBM */ | |
413 | |
414 #ifdef HAVE_BERKELEY_DB | |
415 static Lisp_Object | |
2286 | 416 berkdb_type (Lisp_Database *UNUSED (db)) |
428 | 417 { |
418 return Qberkeley_db; | |
419 } | |
420 | |
421 static Lisp_Object | |
422 berkdb_subtype (Lisp_Database *db) | |
423 { | |
424 if (!db->db_handle) | |
425 return Qnil; | |
426 | |
427 switch (db->db_handle->type) | |
428 { | |
429 case DB_BTREE: return Qbtree; | |
430 case DB_HASH: return Qhash; | |
431 case DB_RECNO: return Qrecno; | |
448 | 432 #if DB_VERSION_MAJOR > 2 |
433 case DB_QUEUE: return Qqueue; | |
434 #endif | |
428 | 435 default: return Qunknown; |
436 } | |
437 } | |
438 | |
439 static Lisp_Object | |
440 berkdb_lasterr (Lisp_Database *db) | |
441 { | |
442 return lisp_strerror (db->dberrno); | |
443 } | |
444 | |
445 static Lisp_Object | |
446 berkdb_get (Lisp_Database *db, Lisp_Object key) | |
447 { | |
448 DBT keydatum, valdatum; | |
449 int status = 0; | |
450 | |
451 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
452 xzero (keydatum); | |
453 xzero (valdatum); | |
454 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
455 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.data, keydatum.size, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
456 db->coding_system); |
428 | 457 |
458 #if DB_VERSION_MAJOR == 1 | |
459 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0); | |
460 #else | |
461 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0); | |
462 #endif /* DB_VERSION_MAJOR */ | |
463 | |
464 if (!status) | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
465 return make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 466 db->coding_system); |
428 | 467 |
468 #if DB_VERSION_MAJOR == 1 | |
469 db->dberrno = (status == 1) ? -1 : errno; | |
470 #else | |
471 db->dberrno = (status < 0) ? -1 : errno; | |
472 #endif /* DB_VERSION_MAJOR */ | |
473 | |
474 return Qnil; | |
475 } | |
476 | |
477 static int | |
478 berkdb_put (Lisp_Database *db, | |
479 Lisp_Object key, | |
480 Lisp_Object val, | |
481 Lisp_Object replace) | |
482 { | |
483 DBT keydatum, valdatum; | |
484 int status = 0; | |
485 | |
486 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
487 xzero (keydatum); | |
488 xzero (valdatum); | |
489 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
490 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.data, keydatum.size, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
491 db->coding_system); |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
492 LISP_STRING_TO_SIZED_EXTERNAL (val, valdatum.data, valdatum.size, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
493 db->coding_system); |
428 | 494 #if DB_VERSION_MAJOR == 1 |
495 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum, | |
496 NILP (replace) ? R_NOOVERWRITE : 0); | |
497 db->dberrno = (status == 1) ? -1 : errno; | |
498 #else | |
499 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum, | |
500 NILP (replace) ? DB_NOOVERWRITE : 0); | |
501 db->dberrno = (status < 0) ? -1 : errno; | |
502 #endif/* DV_VERSION_MAJOR = 2 */ | |
503 | |
504 return status; | |
505 } | |
506 | |
507 static int | |
508 berkdb_remove (Lisp_Database *db, Lisp_Object key) | |
509 { | |
510 DBT keydatum; | |
511 int status; | |
512 | |
513 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
514 xzero (keydatum); | |
515 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
516 LISP_STRING_TO_SIZED_EXTERNAL (key, keydatum.data, keydatum.size, |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
517 db->coding_system); |
428 | 518 |
519 #if DB_VERSION_MAJOR == 1 | |
520 status = db->db_handle->del (db->db_handle, &keydatum, 0); | |
521 #else | |
522 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0); | |
523 #endif /* DB_VERSION_MAJOR */ | |
524 | |
525 if (!status) | |
526 return 0; | |
527 | |
528 #if DB_VERSION_MAJOR == 1 | |
529 db->dberrno = (status == 1) ? -1 : errno; | |
530 #else | |
531 db->dberrno = (status < 0) ? -1 : errno; | |
532 #endif /* DB_VERSION_MAJOR */ | |
533 | |
534 return 1; | |
535 } | |
536 | |
537 static void | |
538 berkdb_map (Lisp_Database *db, Lisp_Object func) | |
539 { | |
540 DBT keydatum, valdatum; | |
541 Lisp_Object key, val; | |
542 DB *dbp = db->db_handle; | |
543 int status; | |
544 | |
545 xzero (keydatum); | |
546 xzero (valdatum); | |
547 | |
548 #if DB_VERSION_MAJOR == 1 | |
549 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); | |
550 status == 0; | |
551 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT)) | |
552 { | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
553 key = make_extstring ((const Extbyte *) keydatum.data, keydatum.size, |
771 | 554 db->coding_system); |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
555 val = make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 556 db->coding_system); |
428 | 557 call2 (func, key, val); |
558 } | |
559 #else | |
560 { | |
561 DBC *dbcp; | |
562 | |
563 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6 | |
564 status = dbp->cursor (dbp, NULL, &dbcp, 0); | |
565 #else | |
566 status = dbp->cursor (dbp, NULL, &dbcp); | |
440 | 567 #endif |
428 | 568 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); |
569 status == 0; | |
570 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT)) | |
571 { | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
572 key = make_extstring ((const Extbyte *) keydatum.data, keydatum.size, |
771 | 573 db->coding_system); |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
574 val = make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 575 db->coding_system); |
428 | 576 call2 (func, key, val); |
577 } | |
578 dbcp->c_close (dbcp); | |
579 } | |
580 #endif /* DB_VERSION_MAJOR */ | |
581 } | |
582 | |
583 static void | |
584 berkdb_close (Lisp_Database *db) | |
585 { | |
586 if (db->db_handle) | |
587 { | |
588 #if DB_VERSION_MAJOR == 1 | |
589 db->db_handle->sync (db->db_handle, 0); | |
590 db->db_handle->close (db->db_handle); | |
591 #else | |
592 db->db_handle->sync (db->db_handle, 0); | |
593 db->db_handle->close (db->db_handle, 0); | |
594 #endif /* DB_VERSION_MAJOR */ | |
595 db->db_handle = NULL; | |
596 } | |
597 } | |
598 | |
599 static DB_FUNCS berk_func_block = | |
600 { | |
601 berkdb_subtype, | |
602 berkdb_type, | |
603 berkdb_get, | |
604 berkdb_put, | |
605 berkdb_remove, | |
606 berkdb_map, | |
607 berkdb_close, | |
608 berkdb_lasterr | |
609 }; | |
610 #endif /* HAVE_BERKELEY_DB */ | |
611 | |
612 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /* | |
613 Return the last error associated with DATABASE. | |
614 */ | |
615 (database)) | |
616 { | |
617 if (NILP (database)) | |
618 return lisp_strerror (errno); | |
619 | |
620 CHECK_DATABASE (database); | |
621 | |
622 return XDATABASE (database)->funcs->last_error (XDATABASE (database)); | |
623 } | |
624 | |
771 | 625 DEFUN ("open-database", Fopen_database, 1, 6, 0, /* |
428 | 626 Return a new database object opened on FILE. |
627 Optional arguments TYPE and SUBTYPE specify the database type. | |
628 Optional argument ACCESS specifies the access rights, which may be any | |
629 combination of 'r' 'w' and '+', for read, write, and creation flags. | |
630 Optional argument MODE gives the permissions to use when opening FILE, | |
631 and defaults to 0755. | |
771 | 632 Optional argument CODESYS specifies the coding system used to encode/decode |
633 data passed to/from the database, and defaults to the value of the | |
634 variable `database-coding-system'. | |
428 | 635 */ |
771 | 636 (file, type, subtype, access_, mode, codesys)) |
428 | 637 { |
638 /* This function can GC */ | |
639 int modemask; | |
640 int accessmask = 0; | |
641 Lisp_Database *db = NULL; | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
642 Extbyte *filename; |
428 | 643 struct gcpro gcpro1, gcpro2; |
644 | |
645 CHECK_STRING (file); | |
646 GCPRO2 (file, access_); | |
647 file = Fexpand_file_name (file, Qnil); | |
648 UNGCPRO; | |
649 | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
650 LISP_PATHNAME_CONVERT_OUT (file, filename); |
428 | 651 |
652 if (NILP (access_)) | |
653 { | |
654 accessmask = O_RDWR | O_CREAT; | |
655 } | |
656 else | |
657 { | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
658 Ibyte *acc; |
428 | 659 CHECK_STRING (access_); |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
660 acc = XSTRING_DATA (access_); |
428 | 661 |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
662 if (qxestrchr (acc, '+')) |
428 | 663 accessmask |= O_CREAT; |
664 | |
665 { | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
666 int rp = !!qxestrchr (acc, 'r'); |
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
667 int wp = !!qxestrchr (acc, 'w'); |
428 | 668 if (rp && wp) accessmask |= O_RDWR; |
669 else if (wp) accessmask |= O_WRONLY; | |
670 else accessmask |= O_RDONLY; | |
671 } | |
672 } | |
673 | |
674 if (NILP (mode)) | |
675 { | |
676 modemask = 0755; /* rwxr-xr-x */ | |
677 } | |
678 else | |
679 { | |
680 CHECK_INT (mode); | |
681 modemask = XINT (mode); | |
682 } | |
683 | |
771 | 684 if (NILP (codesys)) |
685 codesys = Vdatabase_coding_system; | |
686 | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
687 codesys = get_coding_system_for_text_file (codesys, 0); |
771 | 688 |
428 | 689 #ifdef HAVE_DBM |
690 if (NILP (type) || EQ (type, Qdbm)) | |
691 { | |
692 DBM *dbase = dbm_open (filename, accessmask, modemask); | |
693 if (!dbase) | |
694 return Qnil; | |
695 | |
696 db = allocate_database (); | |
697 db->dbm_handle = dbase; | |
698 db->funcs = &ndbm_func_block; | |
771 | 699 db->coding_system = codesys; |
428 | 700 goto db_done; |
701 } | |
702 #endif /* HAVE_DBM */ | |
703 | |
704 #ifdef HAVE_BERKELEY_DB | |
705 if (NILP (type) || EQ (type, Qberkeley_db)) | |
706 { | |
707 DBTYPE real_subtype; | |
708 DB *dbase; | |
709 #if DB_VERSION_MAJOR != 1 | |
710 int status; | |
711 #endif | |
712 | |
713 if (EQ (subtype, Qhash) || NILP (subtype)) | |
714 real_subtype = DB_HASH; | |
715 else if (EQ (subtype, Qbtree)) | |
716 real_subtype = DB_BTREE; | |
717 else if (EQ (subtype, Qrecno)) | |
718 real_subtype = DB_RECNO; | |
448 | 719 #if DB_VERSION_MAJOR > 2 |
720 else if (EQ (subtype, Qqueue)) | |
721 real_subtype = DB_QUEUE; | |
722 #endif | |
428 | 723 else |
563 | 724 invalid_constant ("Unsupported subtype", subtype); |
428 | 725 |
726 #if DB_VERSION_MAJOR == 1 | |
727 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL); | |
728 if (!dbase) | |
729 return Qnil; | |
730 #else | |
731 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY, | |
732 other flags shouldn't be set */ | |
733 if (NILP (access_)) | |
734 accessmask = DB_CREATE; | |
735 else | |
736 { | |
737 char *acc; | |
738 CHECK_STRING (access_); | |
739 acc = (char *) XSTRING_DATA (access_); | |
740 accessmask = 0; | |
741 | |
742 if (strchr (acc, '+')) | |
743 accessmask |= DB_CREATE; | |
744 | |
745 if (strchr (acc, 'r') && !strchr (acc, 'w')) | |
746 accessmask |= DB_RDONLY; | |
747 } | |
448 | 748 #if DB_VERSION_MAJOR == 2 |
428 | 749 status = db_open (filename, real_subtype, accessmask, |
750 modemask, NULL , NULL, &dbase); | |
751 if (status) | |
752 return Qnil; | |
448 | 753 #else |
754 status = db_create (&dbase, NULL, 0); | |
755 if (status) | |
756 return Qnil; | |
1141 | 757 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1) |
448 | 758 status = dbase->open (dbase, filename, NULL, |
759 real_subtype, accessmask, modemask); | |
1141 | 760 #else /* DB_VERSION >= 4.1 */ |
1377 | 761 /* You can't use DB_AUTO_COMMIT unless you have a txn environment. */ |
1141 | 762 status = dbase->open (dbase, NULL, filename, NULL, real_subtype, |
1377 | 763 accessmask, modemask); |
1141 | 764 #endif /* DB_VERSION < 4.1 */ |
448 | 765 if (status) |
766 { | |
767 dbase->close (dbase, 0); | |
768 return Qnil; | |
769 } | |
770 #endif /* DB_VERSION_MAJOR > 2 */ | |
771 /* Normalize into system specific file modes. Only for printing */ | |
772 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR; | |
428 | 773 #endif /* DB_VERSION_MAJOR */ |
774 | |
775 db = allocate_database (); | |
776 db->db_handle = dbase; | |
777 db->funcs = &berk_func_block; | |
771 | 778 db->coding_system = codesys; |
428 | 779 goto db_done; |
780 } | |
781 #endif /* HAVE_BERKELEY_DB */ | |
782 | |
563 | 783 invalid_constant ("Unsupported database type", type); |
428 | 784 return Qnil; |
785 | |
786 db_done: | |
787 db->live_p = 1; | |
788 db->fname = file; | |
789 db->mode = modemask; | |
790 db->access_ = accessmask; | |
791 | |
793 | 792 return wrap_database (db); |
428 | 793 } |
794 | |
795 DEFUN ("put-database", Fput_database, 3, 4, 0, /* | |
796 Store KEY and VALUE in DATABASE. | |
797 If optional fourth arg REPLACE is non-nil, | |
798 replace any existing entry in the database. | |
799 */ | |
800 (key, value, database, replace)) | |
801 { | |
802 CHECK_LIVE_DATABASE (database); | |
803 CHECK_STRING (key); | |
804 CHECK_STRING (value); | |
805 { | |
806 Lisp_Database *db = XDATABASE (database); | |
807 int status = db->funcs->put (db, key, value, replace); | |
808 return status ? Qt : Qnil; | |
809 } | |
810 } | |
811 | |
812 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /* | |
813 Remove KEY from DATABASE. | |
814 */ | |
815 (key, database)) | |
816 { | |
817 CHECK_LIVE_DATABASE (database); | |
818 CHECK_STRING (key); | |
819 { | |
820 Lisp_Database *db = XDATABASE (database); | |
821 int status = db->funcs->rem (db, key); | |
822 return status ? Qt : Qnil; | |
823 } | |
824 } | |
825 | |
826 DEFUN ("get-database", Fget_database, 2, 3, 0, /* | |
827 Return value for KEY in DATABASE. | |
828 If there is no corresponding value, return DEFAULT (defaults to nil). | |
829 */ | |
830 (key, database, default_)) | |
831 { | |
832 CHECK_LIVE_DATABASE (database); | |
833 CHECK_STRING (key); | |
834 { | |
835 Lisp_Database *db = XDATABASE (database); | |
836 Lisp_Object retval = db->funcs->get (db, key); | |
837 return NILP (retval) ? default_ : retval; | |
838 } | |
839 } | |
840 | |
841 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /* | |
842 Map FUNCTION over entries in DATABASE, calling it with two args, | |
843 each key and value in the database. | |
844 */ | |
845 (function, database)) | |
846 { | |
847 CHECK_LIVE_DATABASE (database); | |
848 | |
849 XDATABASE (database)->funcs->map (XDATABASE (database), function); | |
850 | |
851 return Qnil; | |
852 } | |
853 | |
854 void | |
855 syms_of_database (void) | |
856 { | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
857 INIT_LISP_OBJECT (database); |
442 | 858 |
563 | 859 DEFSYMBOL (Qdatabasep); |
428 | 860 #ifdef HAVE_DBM |
563 | 861 DEFSYMBOL (Qdbm); |
428 | 862 #endif |
863 #ifdef HAVE_BERKELEY_DB | |
563 | 864 DEFSYMBOL (Qberkeley_db); |
865 DEFSYMBOL (Qhash); | |
866 DEFSYMBOL (Qbtree); | |
867 DEFSYMBOL (Qrecno); | |
448 | 868 #if DB_VERSION_MAJOR > 2 |
563 | 869 DEFSYMBOL (Qqueue); |
448 | 870 #endif |
563 | 871 DEFSYMBOL (Qunknown); |
428 | 872 #endif |
873 | |
874 DEFSUBR (Fopen_database); | |
875 DEFSUBR (Fdatabasep); | |
876 DEFSUBR (Fmapdatabase); | |
877 DEFSUBR (Fput_database); | |
878 DEFSUBR (Fget_database); | |
879 DEFSUBR (Fremove_database); | |
880 DEFSUBR (Fdatabase_type); | |
881 DEFSUBR (Fdatabase_subtype); | |
882 DEFSUBR (Fdatabase_last_error); | |
883 DEFSUBR (Fdatabase_live_p); | |
884 DEFSUBR (Fdatabase_file_name); | |
885 DEFSUBR (Fclose_database); | |
886 } | |
887 | |
888 void | |
889 vars_of_database (void) | |
890 { | |
891 #ifdef HAVE_DBM | |
892 Fprovide (Qdbm); | |
893 #endif | |
894 #ifdef HAVE_BERKELEY_DB | |
895 Fprovide (Qberkeley_db); | |
896 #endif | |
897 | |
898 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* | |
771 | 899 Default coding system used to convert data in database files. |
428 | 900 */ ); |
771 | 901 Vdatabase_coding_system = Qnative; |
428 | 902 } |