This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add socklen_t probe; Configure maintenance.
[perl5.git] / ext / ODBM_File / ODBM_File.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 #ifdef I_DBM
6 #  include <dbm.h>
7 #else
8 #  ifdef I_RPCSVC_DBM
9 #    include <rpcsvc/dbm.h>
10 #  endif
11 #endif
12
13 #ifdef DBM_BUG_DUPLICATE_FREE 
14 /*
15  * DBM on at least Ultrix and HPUX call dbmclose() from dbminit(),
16  * resulting in duplicate free() because dbmclose() does *not*
17  * check if it has already been called for this DBM.
18  * If some malloc/free calls have been done between dbmclose() and
19  * the next dbminit(), the memory might be used for something else when
20  * it is freed.
21  * Verified to work on ultrix4.3.  Probably will work on HP/UX.
22  * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.
23  */
24 /* Close the previous dbm, and fail to open a new dbm */
25 #define dbmclose()      ((void) dbminit("/tmp/x/y/z/z/y"))
26 #endif
27
28 #include <fcntl.h>
29
30 typedef struct {
31         void *  dbp ;
32         SV *    filter_fetch_key ;
33         SV *    filter_store_key ;
34         SV *    filter_fetch_value ;
35         SV *    filter_store_value ;
36         int     filtering ;
37         } ODBM_File_type;
38
39 typedef ODBM_File_type * ODBM_File ;
40 typedef datum datum_key ;
41 typedef datum datum_value ;
42
43 #define ckFilter(arg,type,name)                                 \
44         if (db->type) {                                         \
45             SV * save_defsv ;                                   \
46             /* printf("filtering %s\n", name) ;*/               \
47             if (db->filtering)                                  \
48                 croak("recursion detected in %s", name) ;       \
49             db->filtering = TRUE ;                              \
50             save_defsv = newSVsv(DEFSV) ;                       \
51             sv_setsv(DEFSV, arg) ;                              \
52             PUSHMARK(sp) ;                                      \
53             (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
54             sv_setsv(arg, DEFSV) ;                              \
55             sv_setsv(DEFSV, save_defsv) ;                       \
56             SvREFCNT_dec(save_defsv) ;                          \
57             db->filtering = FALSE ;                             \
58             /*printf("end of filtering %s\n", name) ;*/         \
59         }
60
61
62 #define odbm_FETCH(db,key)                      fetch(key)
63 #define odbm_STORE(db,key,value,flags)          store(key,value)
64 #define odbm_DELETE(db,key)                     delete(key)
65 #define odbm_FIRSTKEY(db)                       firstkey()
66 #define odbm_NEXTKEY(db,key)                    nextkey(key)
67
68 static int dbmrefcnt;
69
70 #ifndef DBM_REPLACE
71 #define DBM_REPLACE 0
72 #endif
73
74 MODULE = ODBM_File      PACKAGE = ODBM_File     PREFIX = odbm_
75
76 ODBM_File
77 odbm_TIEHASH(dbtype, filename, flags, mode)
78         char *          dbtype
79         char *          filename
80         int             flags
81         int             mode
82         CODE:
83         {
84             char *tmpbuf;
85             void * dbp ;
86             if (dbmrefcnt++)
87                 croak("Old dbm can only open one database");
88             New(0, tmpbuf, strlen(filename) + 5, char);
89             SAVEFREEPV(tmpbuf);
90             sprintf(tmpbuf,"%s.dir",filename);
91             if (stat(tmpbuf, &PL_statbuf) < 0) {
92                 if (flags & O_CREAT) {
93                     if (mode < 0 || close(creat(tmpbuf,mode)) < 0)
94                         croak("ODBM_File: Can't create %s", filename);
95                     sprintf(tmpbuf,"%s.pag",filename);
96                     if (close(creat(tmpbuf,mode)) < 0)
97                         croak("ODBM_File: Can't create %s", filename);
98                 }
99                 else
100                     croak("ODBM_FILE: Can't open %s", filename);
101             }
102             dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
103             RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ;
104             Zero(RETVAL, 1, ODBM_File_type) ;
105             RETVAL->dbp = dbp ;
106             ST(0) = sv_mortalcopy(&PL_sv_undef);
107             sv_setptrobj(ST(0), RETVAL, dbtype);
108         }
109
110 void
111 DESTROY(db)
112         ODBM_File       db
113         CODE:
114         dbmrefcnt--;
115         dbmclose();
116         safefree(db);
117
118 datum_value
119 odbm_FETCH(db, key)
120         ODBM_File       db
121         datum_key       key
122
123 int
124 odbm_STORE(db, key, value, flags = DBM_REPLACE)
125         ODBM_File       db
126         datum_key       key
127         datum_value     value
128         int             flags
129     CLEANUP:
130         if (RETVAL) {
131             if (RETVAL < 0 && errno == EPERM)
132                 croak("No write permission to odbm file");
133             croak("odbm store returned %d, errno %d, key \"%s\"",
134                         RETVAL,errno,key.dptr);
135         }
136
137 int
138 odbm_DELETE(db, key)
139         ODBM_File       db
140         datum_key       key
141
142 datum_key
143 odbm_FIRSTKEY(db)
144         ODBM_File       db
145
146 datum_key
147 odbm_NEXTKEY(db, key)
148         ODBM_File       db
149         datum_key       key
150
151
152 #define setFilter(type)                                 \
153         {                                               \
154             if (db->type)                               \
155                 RETVAL = sv_mortalcopy(db->type) ;      \
156             ST(0) = RETVAL ;                            \
157             if (db->type && (code == &PL_sv_undef)) {   \
158                 SvREFCNT_dec(db->type) ;                \
159                 db->type = Nullsv ;                     \
160             }                                           \
161             else if (code) {                            \
162                 if (db->type)                           \
163                     sv_setsv(db->type, code) ;          \
164                 else                                    \
165                     db->type = newSVsv(code) ;          \
166             }                                           \
167         }
168
169
170
171 SV *
172 filter_fetch_key(db, code)
173         ODBM_File       db
174         SV *            code
175         SV *            RETVAL = &PL_sv_undef ;
176         CODE:
177             setFilter(filter_fetch_key) ;
178
179 SV *
180 filter_store_key(db, code)
181         ODBM_File       db
182         SV *            code
183         SV *            RETVAL =  &PL_sv_undef ;
184         CODE:
185             setFilter(filter_store_key) ;
186
187 SV *
188 filter_fetch_value(db, code)
189         ODBM_File       db
190         SV *            code
191         SV *            RETVAL =  &PL_sv_undef ;
192         CODE:
193             setFilter(filter_fetch_value) ;
194
195 SV *
196 filter_store_value(db, code)
197         ODBM_File       db
198         SV *            code
199         SV *            RETVAL =  &PL_sv_undef ;
200         CODE:
201             setFilter(filter_store_value) ;
202