This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
no such thing as gdbm_clearerr() (from Andy Dougherty)
[perl5.git] / ext / GDBM_File / GDBM_File.xs
CommitLineData
a0d0e21e
LW
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
5#include <gdbm.h>
6#include <fcntl.h>
7
9fe6733a
PM
8typedef struct {
9 GDBM_FILE dbp ;
10 SV * filter_fetch_key ;
11 SV * filter_store_key ;
12 SV * filter_fetch_value ;
13 SV * filter_store_value ;
14 int filtering ;
15 } GDBM_File_type;
16
17typedef GDBM_File_type * GDBM_File ;
18typedef datum datum_key ;
19typedef datum datum_value ;
20
21#define ckFilter(arg,type,name) \
22 if (db->type) { \
23 SV * save_defsv ; \
24 /* printf("filtering %s\n", name) ;*/ \
25 if (db->filtering) \
26 croak("recursion detected in %s", name) ; \
27 db->filtering = TRUE ; \
28 save_defsv = newSVsv(DEFSV) ; \
29 sv_setsv(DEFSV, arg) ; \
30 PUSHMARK(sp) ; \
31 (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \
32 sv_setsv(arg, DEFSV) ; \
33 sv_setsv(DEFSV, save_defsv) ; \
34 SvREFCNT_dec(save_defsv) ; \
35 db->filtering = FALSE ; \
36 /*printf("end of filtering %s\n", name) ;*/ \
37 }
a0d0e21e 38
a0d0e21e 39
9fe6733a
PM
40
41#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
a0d0e21e 42
12f917ad 43typedef void (*FATALFUNC)();
a0d0e21e
LW
44
45static int
f0f333f4 46not_here(char *s)
a0d0e21e
LW
47{
48 croak("GDBM_File::%s not implemented on this architecture", s);
49 return -1;
50}
51
097d66a9
GS
52/* GDBM allocates the datum with system malloc() and expects the user
53 * to free() it. So we either have to free() it immediately, or have
54 * perl free() it when it deallocates the SV, depending on whether
55 * perl uses malloc()/free() or not. */
56static void
caa0600b 57output_datum(pTHX_ SV *arg, char *str, int size)
097d66a9
GS
58{
59#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))
60 sv_usepvn(arg, str, size);
61#else
62 sv_setpvn(arg, str, size);
63 safesysfree(str);
64#endif
65}
66
e50aee73
AD
67/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
68 gdbm_exists, and gdbm_setopt functions. Apparently Slackware
69 (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
70*/
71#ifndef GDBM_FAST
72#define gdbm_exists(db,key) not_here("gdbm_exists")
73#define gdbm_sync(db) (void) not_here("gdbm_sync")
74#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
75#endif
76
a0d0e21e 77static double
f0f333f4 78constant(char *name, int arg)
a0d0e21e
LW
79{
80 errno = 0;
81 switch (*name) {
82 case 'A':
83 break;
84 case 'B':
85 break;
86 case 'C':
87 break;
88 case 'D':
89 break;
90 case 'E':
91 break;
92 case 'F':
93 break;
94 case 'G':
95 if (strEQ(name, "GDBM_CACHESIZE"))
96#ifdef GDBM_CACHESIZE
97 return GDBM_CACHESIZE;
98#else
99 goto not_there;
100#endif
101 if (strEQ(name, "GDBM_FAST"))
102#ifdef GDBM_FAST
103 return GDBM_FAST;
104#else
105 goto not_there;
106#endif
107 if (strEQ(name, "GDBM_FASTMODE"))
108#ifdef GDBM_FASTMODE
109 return GDBM_FASTMODE;
110#else
111 goto not_there;
112#endif
113 if (strEQ(name, "GDBM_INSERT"))
114#ifdef GDBM_INSERT
115 return GDBM_INSERT;
116#else
117 goto not_there;
118#endif
119 if (strEQ(name, "GDBM_NEWDB"))
120#ifdef GDBM_NEWDB
121 return GDBM_NEWDB;
122#else
123 goto not_there;
124#endif
125 if (strEQ(name, "GDBM_READER"))
126#ifdef GDBM_READER
127 return GDBM_READER;
128#else
129 goto not_there;
130#endif
131 if (strEQ(name, "GDBM_REPLACE"))
132#ifdef GDBM_REPLACE
133 return GDBM_REPLACE;
134#else
135 goto not_there;
136#endif
137 if (strEQ(name, "GDBM_WRCREAT"))
138#ifdef GDBM_WRCREAT
139 return GDBM_WRCREAT;
140#else
141 goto not_there;
142#endif
143 if (strEQ(name, "GDBM_WRITER"))
144#ifdef GDBM_WRITER
145 return GDBM_WRITER;
146#else
147 goto not_there;
148#endif
149 break;
150 case 'H':
151 break;
152 case 'I':
153 break;
154 case 'J':
155 break;
156 case 'K':
157 break;
158 case 'L':
159 break;
160 case 'M':
161 break;
162 case 'N':
163 break;
164 case 'O':
165 break;
166 case 'P':
167 break;
168 case 'Q':
169 break;
170 case 'R':
171 break;
172 case 'S':
173 break;
174 case 'T':
175 break;
176 case 'U':
177 break;
178 case 'V':
179 break;
180 case 'W':
181 break;
182 case 'X':
183 break;
184 case 'Y':
185 break;
186 case 'Z':
187 break;
188 }
189 errno = EINVAL;
190 return 0;
191
192not_there:
193 errno = ENOENT;
194 return 0;
195}
196
197MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
198
199double
200constant(name,arg)
201 char * name
202 int arg
203
204
205GDBM_File
206gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
207 char * dbtype
208 char * name
209 int read_write
210 int mode
211 FATALFUNC fatal_func
9fe6733a
PM
212 CODE:
213 {
214 GDBM_FILE dbp ;
a0d0e21e 215
9fe6733a
PM
216 RETVAL = NULL ;
217 if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) {
218 RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
219 Zero(RETVAL, 1, GDBM_File_type) ;
220 RETVAL->dbp = dbp ;
221 }
222
223 }
224 OUTPUT:
225 RETVAL
226
227
228#define gdbm_close(db) gdbm_close(db->dbp)
a0d0e21e
LW
229void
230gdbm_close(db)
231 GDBM_File db
232 CLEANUP:
233
234void
235gdbm_DESTROY(db)
236 GDBM_File db
237 CODE:
238 gdbm_close(db);
239
9fe6733a
PM
240#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
241datum_value
a0d0e21e
LW
242gdbm_FETCH(db, key)
243 GDBM_File db
9fe6733a 244 datum_key key
a0d0e21e 245
9fe6733a 246#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags)
a0d0e21e
LW
247int
248gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
249 GDBM_File db
9fe6733a
PM
250 datum_key key
251 datum_value value
a0d0e21e
LW
252 int flags
253 CLEANUP:
254 if (RETVAL) {
255 if (RETVAL < 0 && errno == EPERM)
256 croak("No write permission to gdbm file");
748a9306 257 croak("gdbm store returned %d, errno %d, key \"%.*s\"",
a0d0e21e 258 RETVAL,errno,key.dsize,key.dptr);
a0d0e21e
LW
259 }
260
9fe6733a 261#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key)
a0d0e21e
LW
262int
263gdbm_DELETE(db, key)
264 GDBM_File db
9fe6733a 265 datum_key key
a0d0e21e 266
9fe6733a
PM
267#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp)
268datum_key
a0d0e21e
LW
269gdbm_FIRSTKEY(db)
270 GDBM_File db
271
9fe6733a
PM
272#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key)
273datum_key
a0d0e21e
LW
274gdbm_NEXTKEY(db, key)
275 GDBM_File db
9fe6733a 276 datum_key key
a0d0e21e 277
9fe6733a 278#define gdbm_reorganize(db) gdbm_reorganize(db->dbp)
a0d0e21e
LW
279int
280gdbm_reorganize(db)
281 GDBM_File db
282
3b35bae3 283
9fe6733a 284#define gdbm_sync(db) gdbm_sync(db->dbp)
3b35bae3
AD
285void
286gdbm_sync(db)
287 GDBM_File db
288
9fe6733a 289#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key)
3b35bae3 290int
c07a80fd 291gdbm_EXISTS(db, key)
3b35bae3 292 GDBM_File db
9fe6733a 293 datum_key key
3b35bae3 294
9fe6733a 295#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
3b35bae3
AD
296int
297gdbm_setopt (db, optflag, optval, optlen)
298 GDBM_File db
299 int optflag
300 int &optval
301 int optlen
302
9fe6733a
PM
303
304#define setFilter(type) \
305 { \
306 if (db->type) \
307 RETVAL = newSVsv(db->type) ; \
308 if (db->type && (code == &PL_sv_undef)) { \
309 SvREFCNT_dec(db->type) ; \
310 db->type = NULL ; \
311 } \
312 else if (code) { \
313 if (db->type) \
314 sv_setsv(db->type, code) ; \
315 else \
316 db->type = newSVsv(code) ; \
317 } \
318 }
319
320
321
322SV *
323filter_fetch_key(db, code)
324 GDBM_File db
325 SV * code
326 SV * RETVAL = &PL_sv_undef ;
327 CODE:
328 setFilter(filter_fetch_key) ;
329 OUTPUT:
330 RETVAL
331
332SV *
333filter_store_key(db, code)
334 GDBM_File db
335 SV * code
336 SV * RETVAL = &PL_sv_undef ;
337 CODE:
338 setFilter(filter_store_key) ;
339 OUTPUT:
340 RETVAL
341
342SV *
343filter_fetch_value(db, code)
344 GDBM_File db
345 SV * code
346 SV * RETVAL = &PL_sv_undef ;
347 CODE:
348 setFilter(filter_fetch_value) ;
349 OUTPUT:
350 RETVAL
351
352SV *
353filter_store_value(db, code)
354 GDBM_File db
355 SV * code
356 SV * RETVAL = &PL_sv_undef ;
357 CODE:
358 setFilter(filter_store_value) ;
359 OUTPUT:
360 RETVAL
361