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 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