Mercurial > hg > xemacs-beta
annotate src/database.c @ 5518:3cc7470ea71c
gnuclient: if TMPDIR was set and connect failed, try again with /tmp
2011-06-03 Aidan Kehoe <kehoea@parhasard.net>
* gnuslib.c (connect_to_unix_server):
Retry with /tmp as a directory in which to search for Unix sockets
if an attempt to connect with some other directory failed (which
may be because gnuclient and gnuserv don't share an environment
value for TMPDIR, or because gnuserv was compiled with USE_TMPDIR
turned off).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Fri, 03 Jun 2011 18:40:57 +0100 |
| parents | 308d34e9f07d |
| children | 56144c8593a8 |
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 8 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
10 option) any later version. |
| 428 | 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 19 |
| 20 /* Synched up with: Not in FSF. */ | |
| 21 | |
| 22 /* Written by Bill Perry */ | |
| 23 /* Substantially rewritten by Martin Buchholz */ | |
| 24 /* db 2.x support added by Andreas Jaeger */ | |
| 771 | 25 /* Mule-ized 6-22-00 Ben Wing */ |
| 428 | 26 |
| 27 #include <config.h> | |
| 28 #include "lisp.h" | |
| 771 | 29 |
| 428 | 30 #include "sysfile.h" |
| 31 #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
|
32 #include "file-coding.h" |
| 428 | 33 |
| 34 #ifndef HAVE_DATABASE | |
| 35 #error HAVE_DATABASE not defined!! | |
| 36 #endif | |
| 37 | |
| 38 #include "database.h" /* Our include file */ | |
| 39 | |
| 40 #ifdef HAVE_BERKELEY_DB | |
| 41 /* Work around Berkeley DB's use of int types which are defined | |
| 42 slightly differently in the not quite yet standard <inttypes.h>. | |
| 43 See db.h for details of why we're resorting to this... */ | |
| 44 /* glibc 2.1 doesn't have this problem with DB 2.x */ | |
| 45 #if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) | |
| 46 #ifdef HAVE_INTTYPES_H | |
| 3739 | 47 #ifndef __BIT_TYPES_DEFINED__ |
| 428 | 48 #define __BIT_TYPES_DEFINED__ |
| 3739 | 49 #endif |
| 428 | 50 #include <inttypes.h> |
| 3739 | 51 #if !HAVE_U_INT8_T |
| 428 | 52 typedef uint8_t u_int8_t; |
| 3739 | 53 #endif |
| 54 #if !HAVE_U_INT16_T | |
| 428 | 55 typedef uint16_t u_int16_t; |
| 3739 | 56 #endif |
| 57 #if !HAVE_U_INT32_T | |
| 428 | 58 typedef uint32_t u_int32_t; |
| 3739 | 59 #endif |
| 428 | 60 #ifdef WE_DONT_NEED_QUADS |
| 3739 | 61 #if !HAVE_U_INT64_T |
| 428 | 62 typedef uint64_t u_int64_t; |
| 3739 | 63 #endif |
| 428 | 64 #endif /* WE_DONT_NEED_QUADS */ |
| 65 #endif /* HAVE_INTTYPES_H */ | |
| 66 #endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */ | |
| 1460 | 67 /* Berkeley DB wants __STDC__ to be defined; else if does `#define const' */ |
| 68 #if ! defined (__STDC__) && ! defined(__cplusplus) | |
| 69 #define __STDC__ 0 | |
| 70 #endif | |
| 442 | 71 #include DB_H_FILE /* Berkeley db's header file */ |
| 428 | 72 #ifndef DB_VERSION_MAJOR |
| 73 # define DB_VERSION_MAJOR 1 | |
| 74 #endif /* DB_VERSION_MAJOR */ | |
| 1141 | 75 #ifndef DB_VERSION_MINOR |
| 76 # define DB_VERSION_MINOR 0 | |
| 77 #endif /* DB_VERSION_MINOR */ | |
| 428 | 78 Lisp_Object Qberkeley_db; |
| 79 Lisp_Object Qhash, Qbtree, Qrecno, Qunknown; | |
| 448 | 80 #if DB_VERSION_MAJOR > 2 |
| 81 Lisp_Object Qqueue; | |
| 82 #endif | |
| 428 | 83 #endif /* HAVE_BERKELEY_DB */ |
| 84 | |
| 85 #ifdef HAVE_DBM | |
|
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
86 # 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
|
87 # include NDBM_H_FILE |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
88 # 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
|
89 |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
90 /* 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
|
91 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
|
92 args given. */ |
|
4824
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 #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
|
95 extern "C" { |
|
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
96 #endif |
|
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
97 |
|
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
98 /* 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
|
99 #define DBM_INSERT 0 |
|
c12b646d84ee
changes to get things to compile under latest cygwin
Ben Wing <ben@xemacs.org>
parents:
4699
diff
changeset
|
100 #define DBM_REPLACE 1 |
|
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. */ |
|
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
103 typedef struct |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
104 { |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
105 char *dptr; |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
106 int dsize; |
|
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
107 } datum; |
|
4824
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 |
|
4991
97c45e3ad810
implement configure test for whether ndbm.h prototypes are broken
Ben Wing <ben@xemacs.org>
parents:
4981
diff
changeset
|
126 # endif /* (not) TRUST_NDBM_H_PROTOTYPES */ |
| 428 | 127 Lisp_Object Qdbm; |
| 128 #endif /* HAVE_DBM */ | |
| 129 | |
| 130 Lisp_Object Vdatabase_coding_system; | |
| 131 | |
| 132 Lisp_Object Qdatabasep; | |
| 133 | |
| 134 typedef struct | |
| 135 { | |
| 136 Lisp_Object (*get_subtype) (Lisp_Database *); | |
| 137 Lisp_Object (*get_type) (Lisp_Database *); | |
| 138 Lisp_Object (*get) (Lisp_Database *, Lisp_Object); | |
| 139 int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); | |
| 140 int (*rem) (Lisp_Database *, Lisp_Object); | |
| 141 void (*map) (Lisp_Database *, Lisp_Object); | |
| 142 void (*close) (Lisp_Database *); | |
| 143 Lisp_Object (*last_error) (Lisp_Database *); | |
| 144 } DB_FUNCS; | |
| 145 | |
| 146 struct Lisp_Database | |
| 147 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
148 NORMAL_LISP_OBJECT_HEADER header; |
| 428 | 149 Lisp_Object fname; |
| 150 int mode; | |
| 151 int access_; | |
| 152 int dberrno; | |
| 153 int live_p; | |
| 154 #ifdef HAVE_DBM | |
| 155 DBM *dbm_handle; | |
| 156 #endif | |
| 157 #ifdef HAVE_BERKELEY_DB | |
| 158 DB *db_handle; | |
| 159 #endif | |
| 160 DB_FUNCS *funcs; | |
| 161 Lisp_Object coding_system; | |
| 162 }; | |
| 163 | |
| 164 #define XDATABASE(x) XRECORD (x, database, Lisp_Database) | |
| 617 | 165 #define wrap_database(p) wrap_record (p, database) |
| 428 | 166 #define DATABASEP(x) RECORDP (x, database) |
| 167 #define CHECK_DATABASE(x) CHECK_RECORD (x, database) | |
| 168 #define CONCHECK_DATABASE(x) CONCHECK_RECORD (x, database) | |
| 169 #define DATABASE_LIVE_P(x) (x->live_p) | |
| 170 | |
| 171 #define CHECK_LIVE_DATABASE(db) do { \ | |
| 172 CHECK_DATABASE (db); \ | |
| 173 if (!DATABASE_LIVE_P (XDATABASE(db))) \ | |
| 563 | 174 invalid_operation ("Attempting to access closed database", db); \ |
| 428 | 175 } while (0) |
| 176 | |
| 177 | |
| 178 static Lisp_Database * | |
| 179 allocate_database (void) | |
| 180 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
181 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
|
182 Lisp_Database *db = XDATABASE (obj); |
| 428 | 183 |
| 184 db->fname = Qnil; | |
| 185 db->live_p = 0; | |
| 186 #ifdef HAVE_BERKELEY_DB | |
| 187 db->db_handle = NULL; | |
| 188 #endif | |
| 189 #ifdef HAVE_DBM | |
| 190 db->dbm_handle = NULL; | |
| 191 #endif | |
| 192 db->access_ = 0; | |
| 193 db->mode = 0; | |
| 194 db->dberrno = 0; | |
| 771 | 195 db->coding_system = Qnil; |
| 428 | 196 return db; |
| 197 } | |
| 198 | |
| 1204 | 199 static const struct memory_description database_description[] = { |
| 934 | 200 { XD_LISP_OBJECT, offsetof (struct Lisp_Database, fname) }, |
| 201 { XD_END} | |
| 202 }; | |
| 203 | |
| 428 | 204 static Lisp_Object |
| 444 | 205 mark_database (Lisp_Object object) |
| 428 | 206 { |
| 444 | 207 Lisp_Database *db = XDATABASE (object); |
| 428 | 208 return db->fname; |
| 209 } | |
| 210 | |
| 211 static void | |
| 2286 | 212 print_database (Lisp_Object obj, Lisp_Object printcharfun, |
| 213 int UNUSED (escapeflag)) | |
| 428 | 214 { |
| 215 Lisp_Database *db = XDATABASE (obj); | |
| 216 | |
| 217 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
218 printing_unreadable_lisp_object (obj, 0); |
| 428 | 219 |
| 793 | 220 write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", |
| 221 3, db->fname, db->funcs->get_type (db), | |
| 222 db->funcs->get_subtype (db)); | |
| 223 | |
|
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
224 write_fmt_string (printcharfun, "%s) ", |
| 793 | 225 (!DATABASE_LIVE_P (db) ? "closed" : |
| 226 (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
|
227 (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
|
228 |
|
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
229 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
|
230 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
|
231 (db->coding_system))); |
|
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
232 |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
233 write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 234 } |
| 235 | |
| 236 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
237 finalize_database (Lisp_Object obj) |
| 428 | 238 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
239 Lisp_Database *db = XDATABASE (obj); |
| 428 | 240 |
| 241 db->funcs->close (db); | |
| 242 } | |
| 243 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
244 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
|
245 mark_database, print_database, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
246 finalize_database, 0, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
247 database_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
248 Lisp_Database); |
| 428 | 249 |
| 250 DEFUN ("close-database", Fclose_database, 1, 1, 0, /* | |
| 251 Close database DATABASE. | |
| 252 */ | |
| 253 (database)) | |
| 254 { | |
| 255 Lisp_Database *db; | |
| 256 CHECK_LIVE_DATABASE (database); | |
| 257 db = XDATABASE (database); | |
| 258 db->funcs->close (db); | |
| 259 db->live_p = 0; | |
| 260 return Qnil; | |
| 261 } | |
| 262 | |
| 263 DEFUN ("database-type", Fdatabase_type, 1, 1, 0, /* | |
| 264 Return the type of database DATABASE. | |
| 265 */ | |
| 266 (database)) | |
| 267 { | |
| 268 CHECK_DATABASE (database); | |
| 269 | |
| 270 return XDATABASE (database)->funcs->get_type (XDATABASE (database)); | |
| 271 } | |
| 272 | |
| 273 DEFUN ("database-subtype", Fdatabase_subtype, 1, 1, 0, /* | |
| 274 Return the subtype of database DATABASE, if any. | |
| 275 */ | |
| 276 (database)) | |
| 277 { | |
| 278 CHECK_DATABASE (database); | |
| 279 | |
| 280 return XDATABASE (database)->funcs->get_subtype (XDATABASE (database)); | |
| 281 } | |
| 282 | |
| 283 DEFUN ("database-live-p", Fdatabase_live_p, 1, 1, 0, /* | |
| 444 | 284 Return t if OBJECT is an active database. |
| 428 | 285 */ |
| 444 | 286 (object)) |
| 428 | 287 { |
| 444 | 288 return DATABASEP (object) && DATABASE_LIVE_P (XDATABASE (object)) ? |
| 289 Qt : Qnil; | |
| 428 | 290 } |
| 291 | |
| 292 DEFUN ("database-file-name", Fdatabase_file_name, 1, 1, 0, /* | |
| 293 Return the filename associated with the database DATABASE. | |
| 294 */ | |
| 295 (database)) | |
| 296 { | |
| 297 CHECK_DATABASE (database); | |
| 298 | |
| 299 return XDATABASE (database)->fname; | |
| 300 } | |
| 301 | |
| 302 DEFUN ("databasep", Fdatabasep, 1, 1, 0, /* | |
| 444 | 303 Return t if OBJECT is a database. |
| 428 | 304 */ |
| 444 | 305 (object)) |
| 428 | 306 { |
| 444 | 307 return DATABASEP (object) ? Qt : Qnil; |
| 428 | 308 } |
| 309 | |
| 310 #ifdef HAVE_DBM | |
| 311 static void | |
| 312 dbm_map (Lisp_Database *db, Lisp_Object func) | |
| 313 { | |
| 314 datum keydatum, valdatum; | |
| 315 Lisp_Object key, val; | |
| 316 | |
| 317 for (keydatum = dbm_firstkey (db->dbm_handle); | |
| 318 keydatum.dptr != NULL; | |
| 319 keydatum = dbm_nextkey (db->dbm_handle)) | |
| 320 { | |
| 321 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
|
322 key = make_extstring ((Extbyte *) keydatum.dptr, keydatum.dsize, |
| 771 | 323 db->coding_system); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
324 val = make_extstring ((Extbyte *) valdatum.dptr, valdatum.dsize, |
| 771 | 325 db->coding_system); |
| 428 | 326 call2 (func, key, val); |
| 327 } | |
| 328 } | |
| 329 | |
| 330 static Lisp_Object | |
| 331 dbm_get (Lisp_Database *db, Lisp_Object key) | |
| 332 { | |
| 333 datum keydatum, valdatum; | |
| 334 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
335 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
|
336 db->coding_system); |
| 428 | 337 valdatum = dbm_fetch (db->dbm_handle, keydatum); |
| 338 | |
| 339 return (valdatum.dptr | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
340 ? make_extstring ((Extbyte *) valdatum.dptr, valdatum.dsize, |
| 771 | 341 db->coding_system) |
| 428 | 342 : Qnil); |
| 343 } | |
| 344 | |
| 345 static int | |
| 346 dbm_put (Lisp_Database *db, | |
| 347 Lisp_Object key, Lisp_Object val, Lisp_Object replace) | |
| 348 { | |
| 349 datum keydatum, valdatum; | |
| 350 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
351 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
|
352 db->coding_system); |
|
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 (key, keydatum.dptr, keydatum.dsize, |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
354 db->coding_system); |
| 428 | 355 |
| 356 return !dbm_store (db->dbm_handle, keydatum, valdatum, | |
| 357 NILP (replace) ? DBM_INSERT : DBM_REPLACE); | |
| 358 } | |
| 359 | |
| 360 static int | |
| 361 dbm_remove (Lisp_Database *db, Lisp_Object key) | |
| 362 { | |
| 363 datum keydatum; | |
| 364 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
365 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
|
366 db->coding_system); |
| 428 | 367 |
| 368 return dbm_delete (db->dbm_handle, keydatum); | |
| 369 } | |
| 370 | |
| 371 static Lisp_Object | |
| 2494 | 372 dbm_type (Lisp_Database *UNUSED (db)) |
| 428 | 373 { |
| 374 return Qdbm; | |
| 375 } | |
| 376 | |
| 377 static Lisp_Object | |
| 2494 | 378 dbm_subtype (Lisp_Database *UNUSED (db)) |
| 428 | 379 { |
| 380 return Qnil; | |
| 381 } | |
| 382 | |
| 383 static Lisp_Object | |
| 384 dbm_lasterr (Lisp_Database *db) | |
| 385 { | |
| 386 return lisp_strerror (db->dberrno); | |
| 387 } | |
| 388 | |
| 389 static void | |
| 390 dbm_closeit (Lisp_Database *db) | |
| 391 { | |
| 392 if (db->dbm_handle) | |
| 393 { | |
| 394 dbm_close (db->dbm_handle); | |
| 395 db->dbm_handle = NULL; | |
| 396 } | |
| 397 } | |
| 398 | |
| 399 static DB_FUNCS ndbm_func_block = | |
| 400 { | |
| 401 dbm_subtype, | |
| 402 dbm_type, | |
| 403 dbm_get, | |
| 404 dbm_put, | |
| 405 dbm_remove, | |
| 406 dbm_map, | |
| 407 dbm_closeit, | |
| 408 dbm_lasterr | |
| 409 }; | |
| 410 #endif /* HAVE_DBM */ | |
| 411 | |
| 412 #ifdef HAVE_BERKELEY_DB | |
| 413 static Lisp_Object | |
| 2286 | 414 berkdb_type (Lisp_Database *UNUSED (db)) |
| 428 | 415 { |
| 416 return Qberkeley_db; | |
| 417 } | |
| 418 | |
| 419 static Lisp_Object | |
| 420 berkdb_subtype (Lisp_Database *db) | |
| 421 { | |
| 422 if (!db->db_handle) | |
| 423 return Qnil; | |
| 424 | |
| 425 switch (db->db_handle->type) | |
| 426 { | |
| 427 case DB_BTREE: return Qbtree; | |
| 428 case DB_HASH: return Qhash; | |
| 429 case DB_RECNO: return Qrecno; | |
| 448 | 430 #if DB_VERSION_MAJOR > 2 |
| 431 case DB_QUEUE: return Qqueue; | |
| 432 #endif | |
| 428 | 433 default: return Qunknown; |
| 434 } | |
| 435 } | |
| 436 | |
| 437 static Lisp_Object | |
| 438 berkdb_lasterr (Lisp_Database *db) | |
| 439 { | |
| 440 return lisp_strerror (db->dberrno); | |
| 441 } | |
| 442 | |
| 443 static Lisp_Object | |
| 444 berkdb_get (Lisp_Database *db, Lisp_Object key) | |
| 445 { | |
| 446 DBT keydatum, valdatum; | |
| 447 int status = 0; | |
| 448 | |
| 449 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 450 xzero (keydatum); | |
| 451 xzero (valdatum); | |
| 452 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
453 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
|
454 db->coding_system); |
| 428 | 455 |
| 456 #if DB_VERSION_MAJOR == 1 | |
| 457 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0); | |
| 458 #else | |
| 459 status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0); | |
| 460 #endif /* DB_VERSION_MAJOR */ | |
| 461 | |
| 462 if (!status) | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
463 return make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 464 db->coding_system); |
| 428 | 465 |
| 466 #if DB_VERSION_MAJOR == 1 | |
| 467 db->dberrno = (status == 1) ? -1 : errno; | |
| 468 #else | |
| 469 db->dberrno = (status < 0) ? -1 : errno; | |
| 470 #endif /* DB_VERSION_MAJOR */ | |
| 471 | |
| 472 return Qnil; | |
| 473 } | |
| 474 | |
| 475 static int | |
| 476 berkdb_put (Lisp_Database *db, | |
| 477 Lisp_Object key, | |
| 478 Lisp_Object val, | |
| 479 Lisp_Object replace) | |
| 480 { | |
| 481 DBT keydatum, valdatum; | |
| 482 int status = 0; | |
| 483 | |
| 484 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 485 xzero (keydatum); | |
| 486 xzero (valdatum); | |
| 487 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
488 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
|
489 db->coding_system); |
|
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 (val, valdatum.data, valdatum.size, |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
491 db->coding_system); |
| 428 | 492 #if DB_VERSION_MAJOR == 1 |
| 493 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum, | |
| 494 NILP (replace) ? R_NOOVERWRITE : 0); | |
| 495 db->dberrno = (status == 1) ? -1 : errno; | |
| 496 #else | |
| 497 status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum, | |
| 498 NILP (replace) ? DB_NOOVERWRITE : 0); | |
| 499 db->dberrno = (status < 0) ? -1 : errno; | |
| 500 #endif/* DV_VERSION_MAJOR = 2 */ | |
| 501 | |
| 502 return status; | |
| 503 } | |
| 504 | |
| 505 static int | |
| 506 berkdb_remove (Lisp_Database *db, Lisp_Object key) | |
| 507 { | |
| 508 DBT keydatum; | |
| 509 int status; | |
| 510 | |
| 511 /* DB Version 2 requires DBT's to be zeroed before use. */ | |
| 512 xzero (keydatum); | |
| 513 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
514 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
|
515 db->coding_system); |
| 428 | 516 |
| 517 #if DB_VERSION_MAJOR == 1 | |
| 518 status = db->db_handle->del (db->db_handle, &keydatum, 0); | |
| 519 #else | |
| 520 status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0); | |
| 521 #endif /* DB_VERSION_MAJOR */ | |
| 522 | |
| 523 if (!status) | |
| 524 return 0; | |
| 525 | |
| 526 #if DB_VERSION_MAJOR == 1 | |
| 527 db->dberrno = (status == 1) ? -1 : errno; | |
| 528 #else | |
| 529 db->dberrno = (status < 0) ? -1 : errno; | |
| 530 #endif /* DB_VERSION_MAJOR */ | |
| 531 | |
| 532 return 1; | |
| 533 } | |
| 534 | |
| 535 static void | |
| 536 berkdb_map (Lisp_Database *db, Lisp_Object func) | |
| 537 { | |
| 538 DBT keydatum, valdatum; | |
| 539 Lisp_Object key, val; | |
| 540 DB *dbp = db->db_handle; | |
| 541 int status; | |
| 542 | |
| 543 xzero (keydatum); | |
| 544 xzero (valdatum); | |
| 545 | |
| 546 #if DB_VERSION_MAJOR == 1 | |
| 547 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); | |
| 548 status == 0; | |
| 549 status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT)) | |
| 550 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
551 key = make_extstring ((const Extbyte *) keydatum.data, keydatum.size, |
| 771 | 552 db->coding_system); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
553 val = make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 554 db->coding_system); |
| 428 | 555 call2 (func, key, val); |
| 556 } | |
| 557 #else | |
| 558 { | |
| 559 DBC *dbcp; | |
| 560 | |
| 561 #if DB_VERSION_MAJOR > 2 || DB_VERSION_MINOR >=6 | |
| 562 status = dbp->cursor (dbp, NULL, &dbcp, 0); | |
| 563 #else | |
| 564 status = dbp->cursor (dbp, NULL, &dbcp); | |
| 440 | 565 #endif |
| 428 | 566 for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); |
| 567 status == 0; | |
| 568 status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT)) | |
| 569 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
570 key = make_extstring ((const Extbyte *) keydatum.data, keydatum.size, |
| 771 | 571 db->coding_system); |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
572 val = make_extstring ((const Extbyte *) valdatum.data, valdatum.size, |
| 771 | 573 db->coding_system); |
| 428 | 574 call2 (func, key, val); |
| 575 } | |
| 576 dbcp->c_close (dbcp); | |
| 577 } | |
| 578 #endif /* DB_VERSION_MAJOR */ | |
| 579 } | |
| 580 | |
| 581 static void | |
| 582 berkdb_close (Lisp_Database *db) | |
| 583 { | |
| 584 if (db->db_handle) | |
| 585 { | |
| 586 #if DB_VERSION_MAJOR == 1 | |
| 587 db->db_handle->sync (db->db_handle, 0); | |
| 588 db->db_handle->close (db->db_handle); | |
| 589 #else | |
| 590 db->db_handle->sync (db->db_handle, 0); | |
| 591 db->db_handle->close (db->db_handle, 0); | |
| 592 #endif /* DB_VERSION_MAJOR */ | |
| 593 db->db_handle = NULL; | |
| 594 } | |
| 595 } | |
| 596 | |
| 597 static DB_FUNCS berk_func_block = | |
| 598 { | |
| 599 berkdb_subtype, | |
| 600 berkdb_type, | |
| 601 berkdb_get, | |
| 602 berkdb_put, | |
| 603 berkdb_remove, | |
| 604 berkdb_map, | |
| 605 berkdb_close, | |
| 606 berkdb_lasterr | |
| 607 }; | |
| 608 #endif /* HAVE_BERKELEY_DB */ | |
| 609 | |
| 610 DEFUN ("database-last-error", Fdatabase_last_error, 0, 1, 0, /* | |
| 611 Return the last error associated with DATABASE. | |
| 612 */ | |
| 613 (database)) | |
| 614 { | |
| 615 if (NILP (database)) | |
| 616 return lisp_strerror (errno); | |
| 617 | |
| 618 CHECK_DATABASE (database); | |
| 619 | |
| 620 return XDATABASE (database)->funcs->last_error (XDATABASE (database)); | |
| 621 } | |
| 622 | |
| 771 | 623 DEFUN ("open-database", Fopen_database, 1, 6, 0, /* |
| 428 | 624 Return a new database object opened on FILE. |
| 625 Optional arguments TYPE and SUBTYPE specify the database type. | |
| 626 Optional argument ACCESS specifies the access rights, which may be any | |
| 627 combination of 'r' 'w' and '+', for read, write, and creation flags. | |
| 628 Optional argument MODE gives the permissions to use when opening FILE, | |
| 629 and defaults to 0755. | |
| 771 | 630 Optional argument CODESYS specifies the coding system used to encode/decode |
| 631 data passed to/from the database, and defaults to the value of the | |
| 632 variable `database-coding-system'. | |
| 428 | 633 */ |
| 771 | 634 (file, type, subtype, access_, mode, codesys)) |
| 428 | 635 { |
| 636 /* This function can GC */ | |
| 637 int modemask; | |
| 638 int accessmask = 0; | |
| 639 Lisp_Database *db = NULL; | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
640 Extbyte *filename; |
| 428 | 641 struct gcpro gcpro1, gcpro2; |
| 642 | |
| 643 CHECK_STRING (file); | |
| 644 GCPRO2 (file, access_); | |
| 645 file = Fexpand_file_name (file, Qnil); | |
| 646 UNGCPRO; | |
| 647 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
648 LISP_PATHNAME_CONVERT_OUT (file, filename); |
| 428 | 649 |
| 650 if (NILP (access_)) | |
| 651 { | |
| 652 accessmask = O_RDWR | O_CREAT; | |
| 653 } | |
| 654 else | |
| 655 { | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
656 Ibyte *acc; |
| 428 | 657 CHECK_STRING (access_); |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
658 acc = XSTRING_DATA (access_); |
| 428 | 659 |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
660 if (qxestrchr (acc, '+')) |
| 428 | 661 accessmask |= O_CREAT; |
| 662 | |
| 663 { | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
664 int rp = !!qxestrchr (acc, 'r'); |
|
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
665 int wp = !!qxestrchr (acc, 'w'); |
| 428 | 666 if (rp && wp) accessmask |= O_RDWR; |
| 667 else if (wp) accessmask |= O_WRONLY; | |
| 668 else accessmask |= O_RDONLY; | |
| 669 } | |
| 670 } | |
| 671 | |
| 672 if (NILP (mode)) | |
| 673 { | |
| 674 modemask = 0755; /* rwxr-xr-x */ | |
| 675 } | |
| 676 else | |
| 677 { | |
| 678 CHECK_INT (mode); | |
| 679 modemask = XINT (mode); | |
| 680 } | |
| 681 | |
| 771 | 682 if (NILP (codesys)) |
| 683 codesys = Vdatabase_coding_system; | |
| 684 | |
|
4351
bc3b9f61018e
Respect the CODESYS argument in #'open-database; don't autodetect EOL.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4124
diff
changeset
|
685 codesys = get_coding_system_for_text_file (codesys, 0); |
| 771 | 686 |
| 428 | 687 #ifdef HAVE_DBM |
| 688 if (NILP (type) || EQ (type, Qdbm)) | |
| 689 { | |
| 690 DBM *dbase = dbm_open (filename, accessmask, modemask); | |
| 691 if (!dbase) | |
| 692 return Qnil; | |
| 693 | |
| 694 db = allocate_database (); | |
| 695 db->dbm_handle = dbase; | |
| 696 db->funcs = &ndbm_func_block; | |
| 771 | 697 db->coding_system = codesys; |
| 428 | 698 goto db_done; |
| 699 } | |
| 700 #endif /* HAVE_DBM */ | |
| 701 | |
| 702 #ifdef HAVE_BERKELEY_DB | |
| 703 if (NILP (type) || EQ (type, Qberkeley_db)) | |
| 704 { | |
| 705 DBTYPE real_subtype; | |
| 706 DB *dbase; | |
| 707 #if DB_VERSION_MAJOR != 1 | |
| 708 int status; | |
| 709 #endif | |
| 710 | |
| 711 if (EQ (subtype, Qhash) || NILP (subtype)) | |
| 712 real_subtype = DB_HASH; | |
| 713 else if (EQ (subtype, Qbtree)) | |
| 714 real_subtype = DB_BTREE; | |
| 715 else if (EQ (subtype, Qrecno)) | |
| 716 real_subtype = DB_RECNO; | |
| 448 | 717 #if DB_VERSION_MAJOR > 2 |
| 718 else if (EQ (subtype, Qqueue)) | |
| 719 real_subtype = DB_QUEUE; | |
| 720 #endif | |
| 428 | 721 else |
| 563 | 722 invalid_constant ("Unsupported subtype", subtype); |
| 428 | 723 |
| 724 #if DB_VERSION_MAJOR == 1 | |
| 725 dbase = dbopen (filename, accessmask, modemask, real_subtype, NULL); | |
| 726 if (!dbase) | |
| 727 return Qnil; | |
| 728 #else | |
| 729 /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY, | |
| 730 other flags shouldn't be set */ | |
| 731 if (NILP (access_)) | |
| 732 accessmask = DB_CREATE; | |
| 733 else | |
| 734 { | |
| 735 char *acc; | |
| 736 CHECK_STRING (access_); | |
| 737 acc = (char *) XSTRING_DATA (access_); | |
| 738 accessmask = 0; | |
| 739 | |
| 740 if (strchr (acc, '+')) | |
| 741 accessmask |= DB_CREATE; | |
| 742 | |
| 743 if (strchr (acc, 'r') && !strchr (acc, 'w')) | |
| 744 accessmask |= DB_RDONLY; | |
| 745 } | |
| 448 | 746 #if DB_VERSION_MAJOR == 2 |
| 428 | 747 status = db_open (filename, real_subtype, accessmask, |
| 748 modemask, NULL , NULL, &dbase); | |
| 749 if (status) | |
| 750 return Qnil; | |
| 448 | 751 #else |
| 752 status = db_create (&dbase, NULL, 0); | |
| 753 if (status) | |
| 754 return Qnil; | |
| 1141 | 755 #if DB_VERSION_MAJOR < 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR < 1) |
| 448 | 756 status = dbase->open (dbase, filename, NULL, |
| 757 real_subtype, accessmask, modemask); | |
| 1141 | 758 #else /* DB_VERSION >= 4.1 */ |
| 1377 | 759 /* You can't use DB_AUTO_COMMIT unless you have a txn environment. */ |
| 1141 | 760 status = dbase->open (dbase, NULL, filename, NULL, real_subtype, |
| 1377 | 761 accessmask, modemask); |
| 1141 | 762 #endif /* DB_VERSION < 4.1 */ |
| 448 | 763 if (status) |
| 764 { | |
| 765 dbase->close (dbase, 0); | |
| 766 return Qnil; | |
| 767 } | |
| 768 #endif /* DB_VERSION_MAJOR > 2 */ | |
| 769 /* Normalize into system specific file modes. Only for printing */ | |
| 770 accessmask = accessmask & DB_RDONLY ? O_RDONLY : O_RDWR; | |
| 428 | 771 #endif /* DB_VERSION_MAJOR */ |
| 772 | |
| 773 db = allocate_database (); | |
| 774 db->db_handle = dbase; | |
| 775 db->funcs = &berk_func_block; | |
| 771 | 776 db->coding_system = codesys; |
| 428 | 777 goto db_done; |
| 778 } | |
| 779 #endif /* HAVE_BERKELEY_DB */ | |
| 780 | |
| 563 | 781 invalid_constant ("Unsupported database type", type); |
| 428 | 782 return Qnil; |
| 783 | |
| 784 db_done: | |
| 785 db->live_p = 1; | |
| 786 db->fname = file; | |
| 787 db->mode = modemask; | |
| 788 db->access_ = accessmask; | |
| 789 | |
| 793 | 790 return wrap_database (db); |
| 428 | 791 } |
| 792 | |
| 793 DEFUN ("put-database", Fput_database, 3, 4, 0, /* | |
| 794 Store KEY and VALUE in DATABASE. | |
| 795 If optional fourth arg REPLACE is non-nil, | |
| 796 replace any existing entry in the database. | |
| 797 */ | |
| 798 (key, value, database, replace)) | |
| 799 { | |
| 800 CHECK_LIVE_DATABASE (database); | |
| 801 CHECK_STRING (key); | |
| 802 CHECK_STRING (value); | |
| 803 { | |
| 804 Lisp_Database *db = XDATABASE (database); | |
| 805 int status = db->funcs->put (db, key, value, replace); | |
| 806 return status ? Qt : Qnil; | |
| 807 } | |
| 808 } | |
| 809 | |
| 810 DEFUN ("remove-database", Fremove_database, 2, 2, 0, /* | |
| 811 Remove KEY from DATABASE. | |
| 812 */ | |
| 813 (key, database)) | |
| 814 { | |
| 815 CHECK_LIVE_DATABASE (database); | |
| 816 CHECK_STRING (key); | |
| 817 { | |
| 818 Lisp_Database *db = XDATABASE (database); | |
| 819 int status = db->funcs->rem (db, key); | |
| 820 return status ? Qt : Qnil; | |
| 821 } | |
| 822 } | |
| 823 | |
| 824 DEFUN ("get-database", Fget_database, 2, 3, 0, /* | |
| 825 Return value for KEY in DATABASE. | |
| 826 If there is no corresponding value, return DEFAULT (defaults to nil). | |
| 827 */ | |
| 828 (key, database, default_)) | |
| 829 { | |
| 830 CHECK_LIVE_DATABASE (database); | |
| 831 CHECK_STRING (key); | |
| 832 { | |
| 833 Lisp_Database *db = XDATABASE (database); | |
| 834 Lisp_Object retval = db->funcs->get (db, key); | |
| 835 return NILP (retval) ? default_ : retval; | |
| 836 } | |
| 837 } | |
| 838 | |
| 839 DEFUN ("map-database", Fmapdatabase, 2, 2, 0, /* | |
| 840 Map FUNCTION over entries in DATABASE, calling it with two args, | |
| 841 each key and value in the database. | |
| 842 */ | |
| 843 (function, database)) | |
| 844 { | |
| 845 CHECK_LIVE_DATABASE (database); | |
| 846 | |
| 847 XDATABASE (database)->funcs->map (XDATABASE (database), function); | |
| 848 | |
| 849 return Qnil; | |
| 850 } | |
| 851 | |
| 852 void | |
| 853 syms_of_database (void) | |
| 854 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3072
diff
changeset
|
855 INIT_LISP_OBJECT (database); |
| 442 | 856 |
| 563 | 857 DEFSYMBOL (Qdatabasep); |
| 428 | 858 #ifdef HAVE_DBM |
| 563 | 859 DEFSYMBOL (Qdbm); |
| 428 | 860 #endif |
| 861 #ifdef HAVE_BERKELEY_DB | |
| 563 | 862 DEFSYMBOL (Qberkeley_db); |
| 863 DEFSYMBOL (Qhash); | |
| 864 DEFSYMBOL (Qbtree); | |
| 865 DEFSYMBOL (Qrecno); | |
| 448 | 866 #if DB_VERSION_MAJOR > 2 |
| 563 | 867 DEFSYMBOL (Qqueue); |
| 448 | 868 #endif |
| 563 | 869 DEFSYMBOL (Qunknown); |
| 428 | 870 #endif |
| 871 | |
| 872 DEFSUBR (Fopen_database); | |
| 873 DEFSUBR (Fdatabasep); | |
| 874 DEFSUBR (Fmapdatabase); | |
| 875 DEFSUBR (Fput_database); | |
| 876 DEFSUBR (Fget_database); | |
| 877 DEFSUBR (Fremove_database); | |
| 878 DEFSUBR (Fdatabase_type); | |
| 879 DEFSUBR (Fdatabase_subtype); | |
| 880 DEFSUBR (Fdatabase_last_error); | |
| 881 DEFSUBR (Fdatabase_live_p); | |
| 882 DEFSUBR (Fdatabase_file_name); | |
| 883 DEFSUBR (Fclose_database); | |
| 884 } | |
| 885 | |
| 886 void | |
| 887 vars_of_database (void) | |
| 888 { | |
| 889 #ifdef HAVE_DBM | |
| 890 Fprovide (Qdbm); | |
| 891 #endif | |
| 892 #ifdef HAVE_BERKELEY_DB | |
| 893 Fprovide (Qberkeley_db); | |
| 894 #endif | |
| 895 | |
| 896 DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* | |
| 771 | 897 Default coding system used to convert data in database files. |
| 428 | 898 */ ); |
| 771 | 899 Vdatabase_coding_system = Qnative; |
| 428 | 900 } |