1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6 #if defined(PERL_IMPLICIT_SYS)
7 # undef open
8 # define open PerlLIO_open3
9 #endif
10
11 #ifdef I_DBM
12 # include <dbm.h>
13 #else
14 # ifdef I_RPCSVC_DBM
15 # include <rpcsvc/dbm.h>
16 # endif
17 #endif
18
19 #ifndef HAS_DBMINIT_PROTO
20 int dbminit(char* filename);
21 int dbmclose(void);
22 datum fetch(datum key);
23 int store(datum key, datum dat);
24 int delete(datum key);
25 datum firstkey(void);
26 datum nextkey(datum key);
27 #endif
28
29 #ifdef DBM_BUG_DUPLICATE_FREE
30 /*
31 * DBM on at least HPUX call dbmclose() from dbminit(),
32 * resulting in duplicate free() because dbmclose() does *not*
33 * check if it has already been called for this DBM.
34 * If some malloc/free calls have been done between dbmclose() and
35 * the next dbminit(), the memory might be used for something else when
36 * it is freed.
37 * Probably will work on HP/UX.
38 * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.
39 */
40 /* Close the previous dbm, and fail to open a new dbm */
41 #define dbmclose() ((void) dbminit("/non/exist/ent"))
42 #endif
43
44 #include <fcntl.h>
45
46 #define fetch_key 0
47 #define store_key 1
48 #define fetch_value 2
49 #define store_value 3
50
51 typedef struct {
52 void * dbp ;
53 SV * filter[4];
54 int filtering ;
55 } ODBM_File_type;
56
57 typedef ODBM_File_type * ODBM_File ;
58 typedef datum datum_key ;
59 typedef datum datum_key_copy ;
60 typedef datum datum_value ;
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 #define MY_CXT_KEY "ODBM_File::_guts" XS_VERSION
69
70 typedef struct {
71 int x_dbmrefcnt;
72 } my_cxt_t;
73
74 START_MY_CXT
75
76 #define dbmrefcnt (MY_CXT.x_dbmrefcnt)
77
78 #ifndef DBM_REPLACE
79 #define DBM_REPLACE 0
80 #endif
81
82 MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_
83
84 BOOT:
85 {
86 MY_CXT_INIT;
87 }
88
89 ODBM_File
odbm_TIEHASH(dbtype,filename,flags,mode)90 odbm_TIEHASH(dbtype, filename, flags, mode)
91 char * dbtype
92 char * filename
93 int flags
94 int mode
95 CODE:
96 {
97 char *tmpbuf;
98 void * dbp ;
99 dMY_CXT;
100
101 if (dbmrefcnt++)
102 croak("Old dbm can only open one database");
103 Newx(tmpbuf, strlen(filename) + 5, char);
104 SAVEFREEPV(tmpbuf);
105 sprintf(tmpbuf,"%s.dir",filename);
106 if ((flags & O_CREAT)) {
107 const int oflags = O_CREAT | O_TRUNC | O_WRONLY | O_EXCL;
108 int created = 0;
109 int fd;
110 if (mode < 0)
111 goto creat_done;
112 if ((fd = open(tmpbuf,oflags,mode)) < 0 && errno != EEXIST)
113 goto creat_done;
114 if (close(fd) < 0)
115 goto creat_done;
116 sprintf(tmpbuf,"%s.pag",filename);
117 if ((fd = open(tmpbuf,oflags,mode)) < 0 && errno != EEXIST)
118 goto creat_done;
119 if (close(fd) < 0)
120 goto creat_done;
121 created = 1;
122 creat_done:
123 if (!created)
124 croak("ODBM_File: Can't create %s", filename);
125 }
126 else {
127 int opened = 0;
128 int fd;
129 if ((fd = open(tmpbuf,O_RDONLY,mode)) < 0)
130 goto rdonly_done;
131 if (close(fd) < 0)
132 goto rdonly_done;
133 opened = 1;
134 rdonly_done:
135 if (!opened)
136 croak("ODBM_FILE: Can't open %s", filename);
137 }
138 dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
139 RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
140 RETVAL->dbp = dbp ;
141 }
142 OUTPUT:
143 RETVAL
144
145 void
146 DESTROY(db)
147 ODBM_File db
148 PREINIT:
149 dMY_CXT;
150 int i = store_value;
151 CODE:
152 dbmrefcnt--;
153 dbmclose();
154 do {
155 if (db->filter[i])
156 SvREFCNT_dec(db->filter[i]);
157 } while (i-- > 0);
158 safefree(db);
159
160 datum_value
161 odbm_FETCH(db, key)
162 ODBM_File db
163 datum_key_copy key
164
165 int
166 odbm_STORE(db, key, value, flags = DBM_REPLACE)
167 ODBM_File db
168 datum_key key
169 datum_value value
170 int flags
171 CLEANUP:
172 if (RETVAL) {
173 if (RETVAL < 0 && errno == EPERM)
174 croak("No write permission to odbm file");
175 croak("odbm store returned %d, errno %d, key \"%s\"",
176 RETVAL,errno,key.dptr);
177 }
178 PERL_UNUSED_VAR(flags);
179
180 int
181 odbm_DELETE(db, key)
182 ODBM_File db
183 datum_key key
184 CODE:
185 /* don't warn about 'delete' being a C++ keyword */
186 GCC_DIAG_IGNORE_STMT(-Wc++-compat);
187 RETVAL = odbm_DELETE(db, key);
188 GCC_DIAG_RESTORE_STMT;
189 OUTPUT:
190 RETVAL
191
192
193 datum_key
194 odbm_FIRSTKEY(db)
195 ODBM_File db
196
197 datum_key
198 odbm_NEXTKEY(db, key)
199 ODBM_File db
200 datum_key key
201
202
203 #define setFilter(type) \
204 { \
205 if (db->type) \
206 RETVAL = sv_mortalcopy(db->type) ; \
207 ST(0) = RETVAL ; \
208 if (db->type && (code == &PL_sv_undef)) { \
209 SvREFCNT_dec(db->type) ; \
210 db->type = Nullsv ; \
211 } \
212 else if (code) { \
213 if (db->type) \
214 sv_setsv(db->type, code) ; \
215 else \
216 db->type = newSVsv(code) ; \
217 } \
218 }
219
220
221
222 SV *
223 filter_fetch_key(db, code)
224 ODBM_File db
225 SV * code
226 SV * RETVAL = &PL_sv_undef ;
227 ALIAS:
228 ODBM_File::filter_fetch_key = fetch_key
229 ODBM_File::filter_store_key = store_key
230 ODBM_File::filter_fetch_value = fetch_value
231 ODBM_File::filter_store_value = store_value
232 CODE:
233 DBM_setFilter(db->filter[ix], code);
234