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
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 #include <gdbm.h>
6 #include <fcntl.h>
7
8 typedef 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
17 typedef GDBM_File_type * GDBM_File ;
18 typedef datum datum_key ;
19 typedef 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         }
38
39
40
41 #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
42
43 typedef void (*FATALFUNC)();
44
45 static int
46 not_here(char *s)
47 {
48     croak("GDBM_File::%s not implemented on this architecture", s);
49     return -1;
50 }
51
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. */
56 static void
57 output_datum(pTHX_ SV *arg, char *str, int size)
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
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
77 static double
78 constant(char *name, int arg)
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
192 not_there:
193     errno = ENOENT;
194     return 0;
195 }
196
197 MODULE = GDBM_File      PACKAGE = GDBM_File     PREFIX = gdbm_
198
199 double
200 constant(name,arg)
201         char *          name
202         int             arg
203
204
205 GDBM_File
206 gdbm_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
212         CODE:
213         {
214             GDBM_FILE   dbp ;
215
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)
229 void
230 gdbm_close(db)
231         GDBM_File       db
232         CLEANUP:
233
234 void
235 gdbm_DESTROY(db)
236         GDBM_File       db
237         CODE:
238         gdbm_close(db);
239
240 #define gdbm_FETCH(db,key)                      gdbm_fetch(db->dbp,key)
241 datum_value
242 gdbm_FETCH(db, key)
243         GDBM_File       db
244         datum_key       key
245
246 #define gdbm_STORE(db,key,value,flags)          gdbm_store(db->dbp,key,value,flags)
247 int
248 gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
249         GDBM_File       db
250         datum_key       key
251         datum_value     value
252         int             flags
253     CLEANUP:
254         if (RETVAL) {
255             if (RETVAL < 0 && errno == EPERM)
256                 croak("No write permission to gdbm file");
257             croak("gdbm store returned %d, errno %d, key \"%.*s\"",
258                         RETVAL,errno,key.dsize,key.dptr);
259         }
260
261 #define gdbm_DELETE(db,key)                     gdbm_delete(db->dbp,key)
262 int
263 gdbm_DELETE(db, key)
264         GDBM_File       db
265         datum_key       key
266
267 #define gdbm_FIRSTKEY(db)                       gdbm_firstkey(db->dbp)
268 datum_key
269 gdbm_FIRSTKEY(db)
270         GDBM_File       db
271
272 #define gdbm_NEXTKEY(db,key)                    gdbm_nextkey(db->dbp,key)
273 datum_key
274 gdbm_NEXTKEY(db, key)
275         GDBM_File       db
276         datum_key       key
277
278 #define gdbm_reorganize(db)                     gdbm_reorganize(db->dbp)
279 int
280 gdbm_reorganize(db)
281         GDBM_File       db
282
283
284 #define gdbm_sync(db)                           gdbm_sync(db->dbp)
285 void
286 gdbm_sync(db)
287         GDBM_File       db
288
289 #define gdbm_EXISTS(db,key)                     gdbm_exists(db->dbp,key)
290 int
291 gdbm_EXISTS(db, key)
292         GDBM_File       db
293         datum_key       key
294
295 #define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
296 int
297 gdbm_setopt (db, optflag, optval, optlen)
298         GDBM_File       db
299         int             optflag
300         int             &optval
301         int             optlen
302
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
322 SV *
323 filter_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
332 SV *
333 filter_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
342 SV *
343 filter_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
352 SV *
353 filter_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