Mercurial > hg > xemacs-beta
annotate src/database.c @ 4903:70089046adef
fix compile problems in intl-encap* under VS6
-------------------- ChangeLog entries follow: --------------------
lib-src/ChangeLog addition:
2010-01-30 Ben Wing <ben@xemacs.org>
* make-mswin-unicode.pl:
Make it possible to specify an overridden prototype in cases where
either Cygwin or Visual Studio has errors in their headers that
can be corrected by falling back to a less qualified type (typically
without const).
src/ChangeLog addition:
2010-01-30 Ben Wing <ben@xemacs.org>
* intl-auto-encap-win32.c:
* intl-auto-encap-win32.c (qxeExtractAssociatedIcon):
* intl-auto-encap-win32.c (qxeExtractIconEx):
* intl-auto-encap-win32.c (qxeCreateMDIWindow):
* intl-auto-encap-win32.c (qxeCreateWindowStation):
* intl-auto-encap-win32.c (qxeDdeCreateStringHandle):
* intl-auto-encap-win32.c (qxeAbortSystemShutdown):
* intl-auto-encap-win32.c (qxeRegConnectRegistry):
* intl-auto-encap-win32.c (qxeGetICMProfile):
* intl-auto-encap-win32.h:
Rebuild.
* intl-encap-win32.c:
* intl-encap-win32.c (qxeUpdateICMRegKey):
Delete manual definitions of functions with former errors in
Cygwin headers but no longer. Use "override" with some functions
where Cygwin or VS6 accidentally omits a const declaration or
includes an extra one. Use "no" on SendMessageTimeout, which
has an error in the VS6 prototype (you could manually fix this
with an ifdef to split the Cygwin vs. VS6 calls, if we ever
actually used this function).
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sat, 30 Jan 2010 20:34:23 -0600 |
parents | a98ca4640147 |
children | 304aebb79cd3 |
rev | line source |
---|---|
428 | 1 /* Database access routines |
2 Copyright (C) 1996, William M. Perry | |
3025 | 3 Copyright (C) 2001, 2002, 2005 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 | |
4837
493e2aa349fd
imported patch cygwin-headers-cosmetic-1-11-10
Ben Wing <ben@xemacs.org>
parents:
4824
diff
changeset
|
88 #ifdef CYGWIN_HEADERS |
4824
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
89 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
90 #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
|
91 extern "C" { |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
92 #endif |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
93 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
94 /* As of Cygwin 1.7.0, the prototypes in ndbm.h are broken when compiling |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
95 using C++, since they are of the form `datum dbm_firstkey()', without any |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
96 args given. */ |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
97 /* 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
|
98 #define DBM_INSERT 0 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
99 #define DBM_REPLACE 1 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
100 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
101 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
102 /* The data and key structure. This structure is defined for compatibility. */ |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
103 typedef struct { |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
104 char *dptr; |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
105 int dsize; |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
106 } datum; |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
107 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
108 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
109 /* 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
|
110 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
|
111 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
112 int dbm_clearerr(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
113 void dbm_close(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
114 int dbm_delete(DBM *, datum); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
115 int dbm_error(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
116 datum dbm_fetch(DBM *, datum); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
117 datum dbm_firstkey(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
118 datum dbm_nextkey(DBM *); |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
119 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
|
120 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
|
121 |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
122 #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
|
123 } |
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
124 #endif |
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 #else |
4699
0e1461b592ce
Check for gdbm/ndbm.h, too.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4351
diff
changeset
|
127 #include NDBM_H_FILE |
4824
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
128 #endif |
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 { | |
3017 | 150 struct LCRECORD_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 { | |
3017 | 183 Lisp_Database *db = ALLOC_LCRECORD_TYPE (Lisp_Database, &lrecord_database); |
428 | 184 |
185 db->fname = Qnil; | |
186 db->live_p = 0; | |
187 #ifdef HAVE_BERKELEY_DB | |
188 db->db_handle = NULL; | |
189 #endif | |
190 #ifdef HAVE_DBM | |
191 db->dbm_handle = NULL; | |
192 #endif | |
193 db->access_ = 0; | |
194 db->mode = 0; | |
195 db->dberrno = 0; | |
771 | 196 db->coding_system = Qnil; |
428 | 197 return db; |
198 } | |
199 | |
1204 | 200 static const struct memory_description database_description[] = { |
934 | 201 { XD_LISP_OBJECT, offsetof (struct Lisp_Database, fname) }, |
202 { XD_END} | |
203 }; | |
204 | |
428 | 205 static Lisp_Object |
444 | 206 mark_database (Lisp_Object object) |
428 | 207 { |
444 | 208 Lisp_Database *db = XDATABASE (object); |
428 | 209 return db->fname; |
210 } | |
211 | |
212 static void | |
2286 | 213 print_database (Lisp_Object obj, Lisp_Object printcharfun, |
214 int UNUSED (escapeflag)) | |
428 | 215 { |
216 Lisp_Database *db = XDATABASE (obj); | |
217 | |
218 if (print_readably) | |
4846 | 219 printing_unreadable_lcrecord (obj, 0); |
428 | 220 |
793 | 221 write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", |
222 3, db->fname, db->funcs->get_type (db), | |
223 db->funcs->get_subtype (db)); | |
224 | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
225 write_fmt_string (printcharfun, "%s) ", |
793 | 226 (!DATABASE_LIVE_P (db) ? "closed" : |
227 (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
|
228 (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
|
229 |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
230 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
|
231 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
|
232 (db->coding_system))); |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
233 |
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
234 write_fmt_string (printcharfun, "0x%x>", db->header.uid); |
428 | 235 } |
236 | |
237 static void | |
238 finalize_database (void *header, int for_disksave) | |
239 { | |
240 Lisp_Database *db = (Lisp_Database *) header; | |
241 | |
242 if (for_disksave) | |
243 { | |
563 | 244 invalid_operation |
793 | 245 ("Can't dump an emacs containing database objects", |
246 wrap_database (db)); | |
428 | 247 } |
248 db->funcs->close (db); | |
249 } | |
250 | |
934 | 251 DEFINE_LRECORD_IMPLEMENTATION ("database", database, |
252 0, /*dumpable-flag*/ | |
253 mark_database, print_database, | |
254 finalize_database, 0, 0, | |
255 database_description, | |
256 Lisp_Database); | |
428 | 257 |
258 DEFUN ("close-database", Fclose_database, 1, 1, 0, /* | |
259 Close database DATABASE. | |
260 */ | |
261 (database)) | |
262 { | |
263 Lisp_Database *db; | |
264 CHECK_LIVE_DATABASE (database); | |
265 db = XDATABASE (database); | |
266 db->funcs->close (db); | |
267 db->live_p = 0; | |
268 return Qnil; | |
269 } | |
270 | |
271 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /* | |
272 Return the type of database DATABASE. | |
273 */ | |
274 (database)) | |
275 { | |
276 CHECK_DATABASE (database); | |
277 | |
278 return XDATABASE (database)->funcs->get_type (XDATABASE (database)); | |
279 } | |
280 | |
281 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /* | |
282 Return the subtype of database DATABASE, if any. | |
283 */ | |
284 (database)) | |
285 { | |
286 CHECK_DATABASE (database); | |
287 | |
288 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database)); | |
289 } | |
290 | |
291 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /* | |
444 | 292 Return t if OBJECT is an active database. |
428 | 293 */ |
444 | 294 (object)) |
428 | 295 { |
444 | 296 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ? |
297 Qt : Qnil; | |
428 | 298 } |
299 | |
300 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /* | |
301 Return the filename associated with the database DATABASE. | |
302 */ | |
303 (database)) | |
304 { | |
305 CHECK_DATABASE (database); | |
306 | |
307 return XDATABASE (database)->fname; | |
308 } | |
309 | |
310 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /* | |
444 | 311 Return t if OBJECT is a database. |
428 | 312 */ |
444 | 313 (object)) |
428 | 314 { |
444 | 315 return DATABASEP (object) ? Qt : Qnil; |
428 | 316 } |
317 | |
318 #ifdef HAVE_DBM | |
319 static void | |
320 dbm_map (Lisp_Database *db, Lisp_Object func) | |
321 { | |
322 datum keydatum, valdatum; | |
323 Lisp_Object key, val; | |
324 | |
325 for (keydatum = dbm_firstkey (db->dbm_handle); | |
326 keydatum.dptr != NULL; | |
327 keydatum = dbm_nextkey (db->dbm_handle)) | |
328 { | |
329 valdatum = dbm_fetch (db->dbm_handle, keydatum); | |
4124 | 330 key = make_ext_string ((Extbyte *) keydatum.dptr, keydatum.dsize, |
771 | 331 db->coding_system); |
4124 | 332 val = make_ext_string ((Extbyte *) valdatum.dptr, valdatum.dsize, |
771 | 333 db->coding_system); |
428 | 334 call2 (func, key, val); |
335 } | |
336 } | |
337 | |
338 static Lisp_Object | |
339 dbm_get (Lisp_Database *db, Lisp_Object key) | |
340 { | |
341 datum keydatum, valdatum; | |
342 | |
771 | 343 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
344 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
345 db->coding_system); | |
428 | 346 valdatum = dbm_fetch (db->dbm_handle, keydatum); |
347 | |
348 return (valdatum.dptr | |
4124 | 349 ? make_ext_string ((Extbyte *) valdatum.dptr, valdatum.dsize, |
771 | 350 db->coding_system) |
428 | 351 : Qnil); |
352 } | |
353 | |
354 static int | |
355 dbm_put (Lisp_Database *db, | |
356 Lisp_Object key, Lisp_Object val, Lisp_Object replace) | |
357 { | |
358 datum keydatum, valdatum; | |
359 | |
771 | 360 TO_EXTERNAL_FORMAT (LISP_STRING, val, |
361 ALLOCA, (valdatum.dptr, valdatum.dsize), | |
362 db->coding_system); | |
363 TO_EXTERNAL_FORMAT (LISP_STRING, key, | |
364 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
365 db->coding_system); | |
428 | 366 |
367 return !dbm_store (db->dbm_handle, keydatum, valdatum, | |
368 NILP (replace) ? DBM_INSERT : DBM_REPLACE); | |
369 } | |
370 | |
371 static int | |
372 dbm_remove (Lisp_Database *db, Lisp_Object key) | |
373 { | |
374 datum keydatum; | |
375 | |
771 | 376 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
377 ALLOCA, (keydatum.dptr, keydatum.dsize), | |
378 db->coding_system); | |
428 | 379 |
380 return dbm_delete (db->dbm_handle, keydatum); | |
381 } | |
382 | |
383 static Lisp_Object | |
2494 | 384 dbm_type (Lisp_Database *UNUSED (db)) |
428 | 385 { |
386 return Qdbm; | |
387 } | |
388 | |
389 static Lisp_Object | |
2494 | 390 dbm_subtype (Lisp_Database *UNUSED (db)) |
428 | 391 { |
392 return Qnil; | |
393 } | |
394 | |
395 static Lisp_Object | |
396 dbm_lasterr (Lisp_Database *db) | |
397 { | |
398 return lisp_strerror (db->dberrno); | |
399 } | |
400 | |
401 static void | |
402 dbm_closeit (Lisp_Database *db) | |
403 { | |
404 if (db->dbm_handle) | |
405 { | |
406 dbm_close (db->dbm_handle); | |
407 db->dbm_handle = NULL; | |
408 } | |
409 } | |
410 | |
411 static DB_FUNCS ndbm_func_block = | |
412 { | |
413 dbm_subtype, | |
414 dbm_type, | |
415 dbm_get, | |
416 dbm_put, | |
417 dbm_remove, | |
418 dbm_map, | |
419 dbm_closeit, | |
420 dbm_lasterr | |
421 }; | |
422 #endif /* HAVE_DBM */ | |
423 | |
424 #ifdef HAVE_BERKELEY_DB | |
425 static Lisp_Object | |
2286 | 426 berkdb_type (Lisp_Database *UNUSED (db)) |
428 | 427 { |
428 return Qberkeley_db; | |
429 } | |
430 | |
431 static Lisp_Object | |
432 berkdb_subtype (Lisp_Database *db) | |
433 { | |
434 if (!db->db_handle) | |
435 return Qnil; | |
436 | |
437 switch (db->db_handle->type) | |
438 { | |
439 case DB_BTREE: return Qbtree; | |
440 case DB_HASH: return Qhash; | |
441 case DB_RECNO: return Qrecno; | |
448 | 442 #if DB_VERSION_MAJOR > 2 |
443 case DB_QUEUE: return Qqueue; | |
444 #endif | |
428 | 445 default: return Qunknown; |
446 } | |
447 } | |
448 | |
449 static Lisp_Object | |
450 berkdb_lasterr (Lisp_Database *db) | |
451 { | |
452 return lisp_strerror (db->dberrno); | |
453 } | |
454 | |
455 static Lisp_Object | |
456 berkdb_get (Lisp_Database *db, Lisp_Object key) | |
457 { | |
458 DBT keydatum, valdatum; | |
459 int status = 0; | |
460 | |
461 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
462 xzero (keydatum); | |
463 xzero (valdatum); | |
464 | |
771 | 465 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
466 ALLOCA, (keydatum.data, keydatum.size), | |
467 db->coding_system); | |
428 | 468 |
469 #if DB_VERSION_MAJOR == 1 | |
470 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0); | |
471 #else | |
472 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0); | |
473 #endif /* DB_VERSION_MAJOR */ | |
474 | |
475 if (!status) | |
1645 | 476 return make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 477 db->coding_system); |
428 | 478 |
479 #if DB_VERSION_MAJOR == 1 | |
480 db->dberrno = (status == 1) ? -1 : errno; | |
481 #else | |
482 db->dberrno = (status < 0) ? -1 : errno; | |
483 #endif /* DB_VERSION_MAJOR */ | |
484 | |
485 return Qnil; | |
486 } | |
487 | |
488 static int | |
489 berkdb_put (Lisp_Database *db, | |
490 Lisp_Object key, | |
491 Lisp_Object val, | |
492 Lisp_Object replace) | |
493 { | |
494 DBT keydatum, valdatum; | |
495 int status = 0; | |
496 | |
497 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
498 xzero (keydatum); | |
499 xzero (valdatum); | |
500 | |
771 | 501 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
502 ALLOCA, (keydatum.data, keydatum.size), | |
503 db->coding_system); | |
504 TO_EXTERNAL_FORMAT (LISP_STRING, val, | |
505 ALLOCA, (valdatum.data, valdatum.size), | |
506 db->coding_system); | |
428 | 507 #if DB_VERSION_MAJOR == 1 |
508 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum, | |
509 NILP (replace) ? R_NOOVERWRITE : 0); | |
510 db->dberrno = (status == 1) ? -1 : errno; | |
511 #else | |
512 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum, | |
513 NILP (replace) ? DB_NOOVERWRITE : 0); | |
514 db->dberrno = (status < 0) ? -1 : errno; | |
515 #endif/* DV_VERSION_MAJOR = 2 */ | |
516 | |
517 return status; | |
518 } | |
519 | |
520 static int | |
521 berkdb_remove (Lisp_Database *db, Lisp_Object key) | |
522 { | |
523 DBT keydatum; | |
524 int status; | |
525 | |
526 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
527 xzero (keydatum); | |
528 | |
771 | 529 TO_EXTERNAL_FORMAT (LISP_STRING, key, |
530 ALLOCA, (keydatum.data, keydatum.size), | |
531 db->coding_system); | |
428 | 532 |
533 #if DB_VERSION_MAJOR == 1 | |
534 status = db->db_handle->del (db->db_handle, &keydatum, 0); | |
535 #else | |
536 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0); | |
537 #endif /* DB_VERSION_MAJOR */ | |
538 | |
539 if (!status) | |
540 return 0; | |
541 | |
542 #if DB_VERSION_MAJOR == 1 | |
543 db->dberrno = (status == 1) ? -1 : errno; | |
544 #else | |
545 db->dberrno = (status < 0) ? -1 : errno; | |
546 #endif /* DB_VERSION_MAJOR */ | |
547 | |
548 return 1; | |
549 } | |
550 | |
551 static void | |
552 berkdb_map (Lisp_Database *db, Lisp_Object func) | |
553 { | |
554 DBT keydatum, valdatum; | |
555 Lisp_Object key, val; | |
556 DB *dbp = db->db_handle; | |
557 int status; | |
558 | |
559 xzero (keydatum); | |
560 xzero (valdatum); | |
561 | |
562 #if DB_VERSION_MAJOR == 1 | |
563 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); | |
564 status == 0; | |
565 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT)) | |
566 { | |
2646 | 567 key = make_ext_string ((const Extbyte *) keydatum.data, keydatum.size, |
771 | 568 db->coding_system); |
2646 | 569 val = make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 570 db->coding_system); |
428 | 571 call2 (func, key, val); |
572 } | |
573 #else | |
574 { | |
575 DBC *dbcp; | |
576 | |
577 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6 | |
578 status = dbp->cursor (dbp, NULL, &dbcp, 0); | |
579 #else | |
580 status = dbp->cursor (dbp, NULL, &dbcp); | |
440 | 581 #endif |
428 | 582 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); |
583 status == 0; | |
584 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT)) | |
585 { | |
1645 | 586 key = make_ext_string ((const Extbyte *) keydatum.data, keydatum.size, |
771 | 587 db->coding_system); |
1645 | 588 val = make_ext_string ((const Extbyte *) valdatum.data, valdatum.size, |
771 | 589 db->coding_system); |
428 | 590 call2 (func, key, val); |
591 } | |
592 dbcp->c_close (dbcp); | |
593 } | |
594 #endif /* DB_VERSION_MAJOR */ | |
595 } | |
596 | |
597 static void | |
598 berkdb_close (Lisp_Database *db) | |
599 { | |
600 if (db->db_handle) | |
601 { | |
602 #if DB_VERSION_MAJOR == 1 | |
603 db->db_handle->sync (db->db_handle, 0); | |
604 db->db_handle->close (db->db_handle); | |
605 #else | |
606 db->db_handle->sync (db->db_handle, 0); | |
607 db->db_handle->close (db->db_handle, 0); | |
608 #endif /* DB_VERSION_MAJOR */ | |
609 db->db_handle = NULL; | |
610 } | |
611 } | |
612 | |
613 static DB_FUNCS berk_func_block = | |
614 { | |
615 berkdb_subtype, | |
616 berkdb_type, | |
617 berkdb_get, | |
618 berkdb_put, | |
619 berkdb_remove, | |
620 berkdb_map, | |
621 berkdb_close, | |
622 berkdb_lasterr | |
623 }; | |
624 #endif /* HAVE_BERKELEY_DB */ | |
625 | |
626 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /* | |
627 Return the last error associated with DATABASE. | |
628 */ | |
629 (database)) | |
630 { | |
631 if (NILP (database)) | |
632 return lisp_strerror (errno); | |
633 | |
634 CHECK_DATABASE (database); | |
635 | |
636 return XDATABASE (database)->funcs->last_error (XDATABASE (database)); | |
637 } | |
638 | |
771 | 639 DEFUN ("open-database", Fopen_database, 1, 6, 0, /* |
428 | 640 Return a new database object opened on FILE. |
641 Optional arguments TYPE and SUBTYPE specify the database type. | |
642 Optional argument ACCESS specifies the access rights, which may be any | |
643 combination of 'r' 'w' and '+', for read, write, and creation flags. | |
644 Optional argument MODE gives the permissions to use when opening FILE, | |
645 and defaults to 0755. | |
771 | 646 Optional argument CODESYS specifies the coding system used to encode/decode |
647 data passed to/from the database, and defaults to the value of the | |
648 variable `database-coding-system'. | |
428 | 649 */ |
771 | 650 (file, type, subtype, access_, mode, codesys)) |
428 | 651 { |
652 /* This function can GC */ | |
653 int modemask; | |
654 int accessmask = 0; | |
655 Lisp_Database *db = NULL; | |
656 char *filename; | |
657 struct gcpro gcpro1, gcpro2; | |
658 | |
659 CHECK_STRING (file); | |
660 GCPRO2 (file, access_); | |
661 file = Fexpand_file_name (file, Qnil); | |
662 UNGCPRO; | |
663 | |
440 | 664 TO_EXTERNAL_FORMAT (LISP_STRING, file, |
665 C_STRING_ALLOCA, filename, | |
666 Qfile_name); | |
428 | 667 |
668 if (NILP (access_)) | |
669 { | |
670 accessmask = O_RDWR | O_CREAT; | |
671 } | |
672 else | |
673 { | |
674 char *acc; | |
675 CHECK_STRING (access_); | |
676 acc = (char *) XSTRING_DATA (access_); | |
677 | |
678 if (strchr (acc, '+')) | |
679 accessmask |= O_CREAT; | |
680 | |
681 { | |
682 char *rp = strchr (acc, 'r'); | |
683 char *wp = strchr (acc, 'w'); | |
684 if (rp && wp) accessmask |= O_RDWR; | |
685 else if (wp) accessmask |= O_WRONLY; | |
686 else accessmask |= O_RDONLY; | |
687 } | |
688 } | |
689 | |
690 if (NILP (mode)) | |
691 { | |
692 modemask = 0755; /* rwxr-xr-x */ | |
693 } | |
694 else | |
695 { | |
696 CHECK_INT (mode); | |
697 modemask = XINT (mode); | |
698 } | |
699 | |
771 | 700 if (NILP (codesys)) |
701 codesys = Vdatabase_coding_system; | |
702 | |
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
703 codesys = get_coding_system_for_text_file (codesys, 0); |
771 | 704 |
428 | 705 #ifdef HAVE_DBM |
706 if (NILP (type) || EQ (type, Qdbm)) | |
707 { | |
708 DBM *dbase = dbm_open (filename, accessmask, modemask); | |
709 if (!dbase) | |
710 return Qnil; | |
711 | |
712 db = allocate_database (); | |
713 db->dbm_handle = dbase; | |
714 db->funcs = &ndbm_func_block; | |
771 | 715 db->coding_system = codesys; |
428 | 716 goto db_done; |
717 } | |
718 #endif /* HAVE_DBM */ | |
719 | |
720 #ifdef HAVE_BERKELEY_DB | |
721 if (NILP (type) || EQ (type, Qberkeley_db)) | |
722 { | |
723 DBTYPE real_subtype; | |
724 DB *dbase; | |
725 #if DB_VERSION_MAJOR != 1 | |
726 int status; | |
727 #endif | |
728 | |
729 if (EQ (subtype, Qhash) || NILP (subtype)) | |
730 real_subtype = DB_HASH; | |
731 else if (EQ (subtype, Qbtree)) | |
732 real_subtype = DB_BTREE; | |
733 else if (EQ (subtype, Qrecno)) | |
734 real_subtype = DB_RECNO; | |
448 | 735 #if DB_VERSION_MAJOR > 2 |
736 else if (EQ (subtype, Qqueue)) | |
737 real_subtype = DB_QUEUE; | |
738 #endif | |
428 | 739 else |
563 | 740 invalid_constant ("Unsupported subtype", subtype); |
428 | 741 |
742 #if DB_VERSION_MAJOR == 1 | |
743 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL); | |
744 if (!dbase) | |
745 return Qnil; | |
746 #else | |
747 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY, | |
748 other flags shouldn't be set */ | |
749 if (NILP (access_)) | |
750 accessmask = DB_CREATE; | |
751 else | |
752 { | |
753 char *acc; | |
754 CHECK_STRING (access_); | |
755 acc = (char *) XSTRING_DATA (access_); | |
756 accessmask = 0; | |
757 | |
758 if (strchr (acc, '+')) | |
759 accessmask |= DB_CREATE; | |
760 | |
761 if (strchr (acc, 'r') && !strchr (acc, 'w')) | |
762 accessmask |= DB_RDONLY; | |
763 } | |
448 | 764 #if DB_VERSION_MAJOR == 2 |
428 | 765 status = db_open (filename, real_subtype, accessmask, |
766 modemask, NULL , NULL, &dbase); | |
767 if (status) | |
768 return Qnil; | |
448 | 769 #else |
770 status = db_create (&dbase, NULL, 0); | |
771 if (status) | |
772 return Qnil; | |
1141 | 773 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1) |
448 | 774 status = dbase->open (dbase, filename, NULL, |
775 real_subtype, accessmask, modemask); | |
1141 | 776 #else /* DB_VERSION >= 4.1 */ |
1377 | 777 /* You can't use DB_AUTO_COMMIT unless you have a txn environment. */ |
1141 | 778 status = dbase->open (dbase, NULL, filename, NULL, real_subtype, |
1377 | 779 accessmask, modemask); |
1141 | 780 #endif /* DB_VERSION < 4.1 */ |
448 | 781 if (status) |
782 { | |
783 dbase->close (dbase, 0); | |
784 return Qnil; | |
785 } | |
786 #endif /* DB_VERSION_MAJOR > 2 */ | |
787 /* Normalize into system specific file modes. Only for printing */ | |
788 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR; | |
428 | 789 #endif /* DB_VERSION_MAJOR */ |
790 | |
791 db = allocate_database (); | |
792 db->db_handle = dbase; | |
793 db->funcs = &berk_func_block; | |
771 | 794 db->coding_system = codesys; |
428 | 795 goto db_done; |
796 } | |
797 #endif /* HAVE_BERKELEY_DB */ | |
798 | |
563 | 799 invalid_constant ("Unsupported database type", type); |
428 | 800 return Qnil; |
801 | |
802 db_done: | |
803 db->live_p = 1; | |
804 db->fname = file; | |
805 db->mode = modemask; | |
806 db->access_ = accessmask; | |
807 | |
793 | 808 return wrap_database (db); |
428 | 809 } |
810 | |
811 DEFUN ("put-database", Fput_database, 3, 4, 0, /* | |
812 Store KEY and VALUE in DATABASE. | |
813 If optional fourth arg REPLACE is non-nil, | |
814 replace any existing entry in the database. | |
815 */ | |
816 (key, value, database, replace)) | |
817 { | |
818 CHECK_LIVE_DATABASE (database); | |
819 CHECK_STRING (key); | |
820 CHECK_STRING (value); | |
821 { | |
822 Lisp_Database *db = XDATABASE (database); | |
823 int status = db->funcs->put (db, key, value, replace); | |
824 return status ? Qt : Qnil; | |
825 } | |
826 } | |
827 | |
828 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /* | |
829 Remove KEY from DATABASE. | |
830 */ | |
831 (key, database)) | |
832 { | |
833 CHECK_LIVE_DATABASE (database); | |
834 CHECK_STRING (key); | |
835 { | |
836 Lisp_Database *db = XDATABASE (database); | |
837 int status = db->funcs->rem (db, key); | |
838 return status ? Qt : Qnil; | |
839 } | |
840 } | |
841 | |
842 DEFUN ("get-database", Fget_database, 2, 3, 0, /* | |
843 Return value for KEY in DATABASE. | |
844 If there is no corresponding value, return DEFAULT (defaults to nil). | |
845 */ | |
846 (key, database, default_)) | |
847 { | |
848 CHECK_LIVE_DATABASE (database); | |
849 CHECK_STRING (key); | |
850 { | |
851 Lisp_Database *db = XDATABASE (database); | |
852 Lisp_Object retval = db->funcs->get (db, key); | |
853 return NILP (retval) ? default_ : retval; | |
854 } | |
855 } | |
856 | |
857 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /* | |
858 Map FUNCTION over entries in DATABASE, calling it with two args, | |
859 each key and value in the database. | |
860 */ | |
861 (function, database)) | |
862 { | |
863 CHECK_LIVE_DATABASE (database); | |
864 | |
865 XDATABASE (database)->funcs->map (XDATABASE (database), function); | |
866 | |
867 return Qnil; | |
868 } | |
869 | |
870 void | |
871 syms_of_database (void) | |
872 { | |
442 | 873 INIT_LRECORD_IMPLEMENTATION (database); |
874 | |
563 | 875 DEFSYMBOL (Qdatabasep); |
428 | 876 #ifdef HAVE_DBM |
563 | 877 DEFSYMBOL (Qdbm); |
428 | 878 #endif |
879 #ifdef HAVE_BERKELEY_DB | |
563 | 880 DEFSYMBOL (Qberkeley_db); |
881 DEFSYMBOL (Qhash); | |
882 DEFSYMBOL (Qbtree); | |
883 DEFSYMBOL (Qrecno); | |
448 | 884 #if DB_VERSION_MAJOR > 2 |
563 | 885 DEFSYMBOL (Qqueue); |
448 | 886 #endif |
563 | 887 DEFSYMBOL (Qunknown); |
428 | 888 #endif |
889 | |
890 DEFSUBR (Fopen_database); | |
891 DEFSUBR (Fdatabasep); | |
892 DEFSUBR (Fmapdatabase); | |
893 DEFSUBR (Fput_database); | |
894 DEFSUBR (Fget_database); | |
895 DEFSUBR (Fremove_database); | |
896 DEFSUBR (Fdatabase_type); | |
897 DEFSUBR (Fdatabase_subtype); | |
898 DEFSUBR (Fdatabase_last_error); | |
899 DEFSUBR (Fdatabase_live_p); | |
900 DEFSUBR (Fdatabase_file_name); | |
901 DEFSUBR (Fclose_database); | |
902 } | |
903 | |
904 void | |
905 vars_of_database (void) | |
906 { | |
907 #ifdef HAVE_DBM | |
908 Fprovide (Qdbm); | |
909 #endif | |
910 #ifdef HAVE_BERKELEY_DB | |
911 Fprovide (Qberkeley_db); | |
912 #endif | |
913 | |
914 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* | |
771 | 915 Default coding system used to convert data in database files. |
428 | 916 */ ); |
771 | 917 Vdatabase_coding_system = Qnative; |
428 | 918 } |