ext/GDBM_File/GDBM_File.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 #include <gdbm.h>
   6 #include <fcntl.h>
   7
   8 typedef struct {
   9         GDBM_FILE       dbp ;
  10         SV *    filter_fetch_key ;
  11         SV *    filter_store_key ;
  12         SV *    filter_fetch_value ;
  13         SV *    filter_store_value ;
  14         int     filtering ;
  15         } GDBM_File_type;
  16
  17 typedef GDBM_File_type * GDBM_File ;
  18 typedef datum datum_key ;
  19 typedef datum datum_value ;
  20 typedef datum datum_key_copy;
  21
  22 #define ckFilter(arg,type,name)                                 \
  23         if (db->type) {                                         \
  24             SV * save_defsv ;                                   \
  25             /* printf("filtering %s\n", name) ;*/               \
  26             if (db->filtering)                                  \
  27                 croak("recursion detected in %s", name) ;       \
  28             db->filtering = TRUE ;                              \
  29             save_defsv = newSVsv(DEFSV) ;                       \
  30             sv_setsv(DEFSV, arg) ;                              \
  31             PUSHMARK(sp) ;                                      \
  32             (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
  33             sv_setsv(arg, DEFSV) ;                              \
  34             sv_setsv(DEFSV, save_defsv) ;                       \
  35             SvREFCNT_dec(save_defsv) ;                          \
  36             db->filtering = FALSE ;                             \
  37             /*printf("end of filtering %s\n", name) ;*/         \
  38         }
  39
  40
  41
  42 #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
  43
  44 typedef void (*FATALFUNC)();
  45
  46 #ifndef GDBM_FAST
  47 static int
  48 not_here(char *s)
  49 {
  50     croak("GDBM_File::%s not implemented on this architecture", s);
  51     return -1;
  52 }
  53 #endif
  54
  55 /* GDBM allocates the datum with system malloc() and expects the user
  56  * to free() it.  So we either have to free() it immediately, or have
  57  * perl free() it when it deallocates the SV, depending on whether
  58  * perl uses malloc()/free() or not. */
  59 static void
  60 output_datum(pTHX_ SV *arg, char *str, int size)
  61 {
  62 #if (!defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST)
  63         sv_usepvn(arg, str, size);
  64 #else
  65         sv_setpvn(arg, str, size);
  66         safesysfree(str);
  67 #endif
  68 }
  69
  70 /* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
  71    gdbm_exists, and gdbm_setopt functions.  Apparently Slackware
  72    (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
  73 */
  74 #ifndef GDBM_FAST
  75 #define gdbm_exists(db,key) not_here("gdbm_exists")
  76 #define gdbm_sync(db) (void) not_here("gdbm_sync")
  77 #define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
  78 #endif
  79
  80 #include "const-c.inc"
  81
  82 MODULE = GDBM_File      PACKAGE = GDBM_File     PREFIX = gdbm_
  83
  84 INCLUDE: const-xs.inc
  85
  86 GDBM_File
  87 gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
  88         char *          dbtype
  89         char *          name
  90         int             read_write
  91         int             mode
  92         FATALFUNC       fatal_func
  93         CODE:
  94         {
  95             GDBM_FILE   dbp ;
  96
  97             RETVAL = NULL ;
  98             if ((dbp =  gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) {
  99                 RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
 100                 Zero(RETVAL, 1, GDBM_File_type) ;
 101                 RETVAL->dbp = dbp ;
 102             }
 103
 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         CODE:
 119         gdbm_close(db);
 120         safefree(db);
 121
 122 #define gdbm_FETCH(db,key)                      gdbm_fetch(db->dbp,key)
 123 datum_value
 124 gdbm_FETCH(db, key)
 125         GDBM_File       db
 126         datum_key_copy  key
 127
 128 #define gdbm_STORE(db,key,value,flags)          gdbm_store(db->dbp,key,value,flags)
 129 int
 130 gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
 131         GDBM_File       db
 132         datum_key       key
 133         datum_value     value
 134         int             flags
 135     CLEANUP:
 136         if (RETVAL) {
 137             if (RETVAL < 0 && errno == EPERM)
 138                 croak("No write permission to gdbm file");
 139             croak("gdbm store returned %d, errno %d, key \"%.*s\"",
 140                         RETVAL,errno,key.dsize,key.dptr);
 141         }
 142
 143 #define gdbm_DELETE(db,key)                     gdbm_delete(db->dbp,key)
 144 int
 145 gdbm_DELETE(db, key)
 146         GDBM_File       db
 147         datum_key       key
 148
 149 #define gdbm_FIRSTKEY(db)                       gdbm_firstkey(db->dbp)
 150 datum_key
 151 gdbm_FIRSTKEY(db)
 152         GDBM_File       db
 153
 154 #define gdbm_NEXTKEY(db,key)                    gdbm_nextkey(db->dbp,key)
 155 datum_key
 156 gdbm_NEXTKEY(db, key)
 157         GDBM_File       db
 158         datum_key       key
 159
 160 #define gdbm_reorganize(db)                     gdbm_reorganize(db->dbp)
 161 int
 162 gdbm_reorganize(db)
 163         GDBM_File       db
 164
 165
 166 #define gdbm_sync(db)                           gdbm_sync(db->dbp)
 167 void
 168 gdbm_sync(db)
 169         GDBM_File       db
 170
 171 #define gdbm_EXISTS(db,key)                     gdbm_exists(db->dbp,key)
 172 int
 173 gdbm_EXISTS(db, key)
 174         GDBM_File       db
 175         datum_key       key
 176
 177 #define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
 178 int
 179 gdbm_setopt (db, optflag, optval, optlen)
 180         GDBM_File       db
 181         int             optflag
 182         int             &optval
 183         int             optlen
 184
 185
 186 #define setFilter(type)                                 \
 187         {                                               \
 188             if (db->type)                               \
 189                 RETVAL = sv_mortalcopy(db->type) ;      \
 190             ST(0) = RETVAL ;                            \
 191             if (db->type && (code == &PL_sv_undef)) {   \
 192                 SvREFCNT_dec(db->type) ;                \
 193                 db->type = NULL ;                       \
 194             }                                           \
 195             else if (code) {                            \
 196                 if (db->type)                           \
 197                     sv_setsv(db->type, code) ;          \
 198                 else                                    \
 199                     db->type = newSVsv(code) ;          \
 200             }                                           \
 201         }
 202
 203
 204
 205 SV *
 206 filter_fetch_key(db, code)
 207         GDBM_File       db
 208         SV *            code
 209         SV *            RETVAL = &PL_sv_undef ;
 210         CODE:
 211             setFilter(filter_fetch_key) ;
 212
 213 SV *
 214 filter_store_key(db, code)
 215         GDBM_File       db
 216         SV *            code
 217         SV *            RETVAL =  &PL_sv_undef ;
 218         CODE:
 219             setFilter(filter_store_key) ;
 220
 221 SV *
 222 filter_fetch_value(db, code)
 223         GDBM_File       db
 224         SV *            code
 225         SV *            RETVAL =  &PL_sv_undef ;
 226         CODE:
 227             setFilter(filter_fetch_value) ;
 228
 229 SV *
 230 filter_store_value(db, code)
 231         GDBM_File       db
 232         SV *            code
 233         SV *            RETVAL =  &PL_sv_undef ;
 234         CODE:
 235             setFilter(filter_store_value) ;
 236