1 #define PERL_NO_GET_CONTEXT 2 3 #include "EXTERN.h" 4 #include "perl.h" 5 #include "XSUB.h" 6 7 #include <gdbm.h> 8 #include <fcntl.h> 9 10 #define fetch_key 0 11 #define store_key 1 12 #define fetch_value 2 13 #define store_value 3 14 15 typedef struct { 16 GDBM_FILE dbp ; 17 SV * filter[4]; 18 int filtering ; 19 } GDBM_File_type; 20 21 typedef GDBM_File_type * GDBM_File ; 22 typedef datum datum_key ; 23 typedef datum datum_value ; 24 typedef datum datum_key_copy; 25 26 #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ 27 28 #if defined(GDBM_VERSION_MAJOR) && defined(GDBM_VERSION_MINOR) \ 29 && GDBM_VERSION_MAJOR > 1 || \ 30 (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9) 31 typedef void (*FATALFUNC)(const char *); 32 #else 33 typedef void (*FATALFUNC)(); 34 #endif 35 36 #ifndef GDBM_FAST 37 static int 38 not_here(char *s) 39 { 40 croak("GDBM_File::%s not implemented on this architecture", s); 41 return -1; 42 } 43 #endif 44 45 /* GDBM allocates the datum with system malloc() and expects the user 46 * to free() it. So we either have to free() it immediately, or have 47 * perl free() it when it deallocates the SV, depending on whether 48 * perl uses malloc()/free() or not. */ 49 static void 50 output_datum(pTHX_ SV *arg, char *str, int size) 51 { 52 sv_setpvn(arg, str, size); 53 # undef free 54 free(str); 55 } 56 57 /* Versions of gdbm prior to 1.7x might not have the gdbm_sync, 58 gdbm_exists, and gdbm_setopt functions. Apparently Slackware 59 (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991). 60 */ 61 #ifndef GDBM_FAST 62 #define gdbm_exists(db,key) not_here("gdbm_exists") 63 #define gdbm_sync(db) (void) not_here("gdbm_sync") 64 #define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt") 65 #endif 66 67 static void 68 croak_string(const char *message) { 69 Perl_croak_nocontext("%s", message); 70 } 71 72 #include "const-c.inc" 73 74 MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ 75 76 INCLUDE: const-xs.inc 77 78 GDBM_File 79 gdbm_TIEHASH(dbtype, name, read_write, mode) 80 char * dbtype 81 char * name 82 int read_write 83 int mode 84 CODE: 85 { 86 GDBM_FILE dbp ; 87 88 RETVAL = NULL ; 89 if ((dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, 90 (FATALFUNC) croak_string))) { 91 RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)) ; 92 RETVAL->dbp = dbp ; 93 } 94 95 } 96 OUTPUT: 97 RETVAL 98 99 100 #define gdbm_close(db) gdbm_close(db->dbp) 101 void 102 gdbm_close(db) 103 GDBM_File db 104 CLEANUP: 105 106 void 107 gdbm_DESTROY(db) 108 GDBM_File db 109 PREINIT: 110 int i = store_value; 111 CODE: 112 gdbm_close(db); 113 do { 114 if (db->filter[i]) 115 SvREFCNT_dec(db->filter[i]); 116 } while (i-- > 0); 117 safefree(db); 118 119 #define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key) 120 datum_value 121 gdbm_FETCH(db, key) 122 GDBM_File db 123 datum_key_copy key 124 125 #define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags) 126 int 127 gdbm_STORE(db, key, value, flags = GDBM_REPLACE) 128 GDBM_File db 129 datum_key key 130 datum_value value 131 int flags 132 CLEANUP: 133 if (RETVAL) { 134 if (RETVAL < 0 && errno == EPERM) 135 croak("No write permission to gdbm file"); 136 croak("gdbm store returned %d, errno %d, key \"%.*s\"", 137 RETVAL,errno,key.dsize,key.dptr); 138 } 139 140 #define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key) 141 int 142 gdbm_DELETE(db, key) 143 GDBM_File db 144 datum_key key 145 146 #define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp) 147 datum_key 148 gdbm_FIRSTKEY(db) 149 GDBM_File db 150 151 #define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key) 152 datum_key 153 gdbm_NEXTKEY(db, key) 154 GDBM_File db 155 datum_key key 156 157 #define gdbm_reorganize(db) gdbm_reorganize(db->dbp) 158 int 159 gdbm_reorganize(db) 160 GDBM_File db 161 162 163 #define gdbm_sync(db) gdbm_sync(db->dbp) 164 void 165 gdbm_sync(db) 166 GDBM_File db 167 168 #define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) 169 int 170 gdbm_EXISTS(db, key) 171 GDBM_File db 172 datum_key key 173 174 #define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen) 175 int 176 gdbm_setopt (db, optflag, optval, optlen) 177 GDBM_File db 178 int optflag 179 int &optval 180 int optlen 181 182 183 SV * 184 filter_fetch_key(db, code) 185 GDBM_File db 186 SV * code 187 SV * RETVAL = &PL_sv_undef ; 188 ALIAS: 189 GDBM_File::filter_fetch_key = fetch_key 190 GDBM_File::filter_store_key = store_key 191 GDBM_File::filter_fetch_value = fetch_value 192 GDBM_File::filter_store_value = store_value 193 CODE: 194 DBM_setFilter(db->filter[ix], code); 195