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