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