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
  21 #define ckFilter(arg,type,name)                                 \
  22         if (db->type) {                                         \
  23             SV * save_defsv ;                                   \
  24             /* printf("filtering %s\n", name) ;*/               \
  25             if (db->filtering)                                  \
  26                 croak("recursion detected in %s", name) ;       \
  27             db->filtering = TRUE ;                              \
  28             save_defsv = newSVsv(DEFSV) ;                       \
  29             sv_setsv(DEFSV, arg) ;                              \
  30             PUSHMARK(sp) ;                                      \
  31             (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
  32             sv_setsv(arg, DEFSV) ;                              \
  33             sv_setsv(DEFSV, save_defsv) ;                       \
  34             SvREFCNT_dec(save_defsv) ;                          \
  35             db->filtering = FALSE ;                             \
  36             /*printf("end of filtering %s\n", name) ;*/         \
  37         }
  38
  39
  40
  41 #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
  42
  43 typedef void (*FATALFUNC)();
  44
  45 #ifndef GDBM_FAST
  46 static int
  47 not_here(char *s)
  48 {
  49     croak("GDBM_File::%s not implemented on this architecture", s);
  50     return -1;
  51 }
  52 #endif
  53
  54 /* GDBM allocates the datum with system malloc() and expects the user
  55  * to free() it.  So we either have to free() it immediately, or have
  56  * perl free() it when it deallocates the SV, depending on whether
  57  * perl uses malloc()/free() or not. */
  58 static void
  59 output_datum(pTHX_ SV *arg, char *str, int size)
  60 {
  61 #if (!defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST)
  62         sv_usepvn(arg, str, size);
  63 #else
  64         sv_setpvn(arg, str, size);
  65         safesysfree(str);
  66 #endif
  67 }
  68
  69 /* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
  70    gdbm_exists, and gdbm_setopt functions.  Apparently Slackware
  71    (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
  72 */
  73 #ifndef GDBM_FAST
  74 #define gdbm_exists(db,key) not_here("gdbm_exists")
  75 #define gdbm_sync(db) (void) not_here("gdbm_sync")
  76 #define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
  77 #endif
  78
  79 #define PERL_constant_NOTFOUND  1
  80 #define PERL_constant_NOTDEF    2
  81 #define PERL_constant_ISIV      3
  82 #define PERL_constant_ISNO      4
  83 #define PERL_constant_ISNV      5
  84 #define PERL_constant_ISPV      6
  85 #define PERL_constant_ISPVN     7
  86 #define PERL_constant_ISUNDEF   8
  87 #define PERL_constant_ISUV      9
  88 #define PERL_constant_ISYES     10
  89
  90 static int
  91 constant (const char *name, STRLEN len, IV *iv_return) {
  92   /* Initially switch on the length of the name.  */
  93   /* When generated this function returned values for the list of names given
  94      in this section of perl code.  Rather than manually editing these functions
  95      to add or remove constants, which would result in this comment and section
  96      of code becoming inaccurate, we recommend that you edit this section of
  97      code, and use it to regenerate a new set of constant functions which you
  98      then use to replace the originals.
  99
 100      Regenerate these constant functions by feeding this entire source file to
 101      perl -x
 102
 103 #!../../perl -w
 104 use ExtUtils::Constant qw (constant_types C_constant XS_constant);
 105
 106 my $types = {map {($_, 1)} qw(IV)};
 107 my @names = (qw(GDBM_CACHESIZE GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB
 108                GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER));
 109
 110 print constant_types(); # macro defs
 111 foreach (C_constant ("GDBM_File", 'constant', 'IV', $types, undef, 8, @names) ) {
 112     print $_, "\n"; # C constant subs
 113 }
 114 print "#### XS Section:\n";
 115 print XS_constant ("GDBM_File", $types);
 116 __END__
 117    */
 118
 119   switch (len) {
 120   case 9:
 121     if (memEQ(name, "GDBM_FAST", 9)) {
 122 #ifdef GDBM_FAST
 123       *iv_return = GDBM_FAST;
 124       return PERL_constant_ISIV;
 125 #else
 126       return PERL_constant_NOTDEF;
 127 #endif
 128     }
 129     break;
 130   case 10:
 131     if (memEQ(name, "GDBM_NEWDB", 10)) {
 132 #ifdef GDBM_NEWDB
 133       *iv_return = GDBM_NEWDB;
 134       return PERL_constant_ISIV;
 135 #else
 136       return PERL_constant_NOTDEF;
 137 #endif
 138     }
 139     break;
 140   case 11:
 141     /* Names all of length 11.  */
 142     /* GDBM_INSERT GDBM_NOLOCK GDBM_READER GDBM_WRITER */
 143     /* Offset 6 gives the best switch position.  */
 144     switch (name[6]) {
 145     case 'E':
 146       if (memEQ(name, "GDBM_READER", 11)) {
 147       /*                     ^           */
 148 #ifdef GDBM_READER
 149         *iv_return = GDBM_READER;
 150         return PERL_constant_ISIV;
 151 #else
 152         return PERL_constant_NOTDEF;
 153 #endif
 154       }
 155       break;
 156     case 'N':
 157       if (memEQ(name, "GDBM_INSERT", 11)) {
 158       /*                     ^           */
 159 #ifdef GDBM_INSERT
 160         *iv_return = GDBM_INSERT;
 161         return PERL_constant_ISIV;
 162 #else
 163         return PERL_constant_NOTDEF;
 164 #endif
 165       }
 166       break;
 167     case 'O':
 168       if (memEQ(name, "GDBM_NOLOCK", 11)) {
 169       /*                     ^           */
 170 #ifdef GDBM_NOLOCK
 171         *iv_return = GDBM_NOLOCK;
 172         return PERL_constant_ISIV;
 173 #else
 174         return PERL_constant_NOTDEF;
 175 #endif
 176       }
 177       break;
 178     case 'R':
 179       if (memEQ(name, "GDBM_WRITER", 11)) {
 180       /*                     ^           */
 181 #ifdef GDBM_WRITER
 182         *iv_return = GDBM_WRITER;
 183         return PERL_constant_ISIV;
 184 #else
 185         return PERL_constant_NOTDEF;
 186 #endif
 187       }
 188       break;
 189     }
 190     break;
 191   case 12:
 192     /* Names all of length 12.  */
 193     /* GDBM_REPLACE GDBM_WRCREAT */
 194     /* Offset 10 gives the best switch position.  */
 195     switch (name[10]) {
 196     case 'A':
 197       if (memEQ(name, "GDBM_WRCREAT", 12)) {
 198       /*                         ^        */
 199 #ifdef GDBM_WRCREAT
 200         *iv_return = GDBM_WRCREAT;
 201         return PERL_constant_ISIV;
 202 #else
 203         return PERL_constant_NOTDEF;
 204 #endif
 205       }
 206       break;
 207     case 'C':
 208       if (memEQ(name, "GDBM_REPLACE", 12)) {
 209       /*                         ^        */
 210 #ifdef GDBM_REPLACE
 211         *iv_return = GDBM_REPLACE;
 212         return PERL_constant_ISIV;
 213 #else
 214         return PERL_constant_NOTDEF;
 215 #endif
 216       }
 217       break;
 218     }
 219     break;
 220   case 13:
 221     if (memEQ(name, "GDBM_FASTMODE", 13)) {
 222 #ifdef GDBM_FASTMODE
 223       *iv_return = GDBM_FASTMODE;
 224       return PERL_constant_ISIV;
 225 #else
 226       return PERL_constant_NOTDEF;
 227 #endif
 228     }
 229     break;
 230   case 14:
 231     if (memEQ(name, "GDBM_CACHESIZE", 14)) {
 232 #ifdef GDBM_CACHESIZE
 233       *iv_return = GDBM_CACHESIZE;
 234       return PERL_constant_ISIV;
 235 #else
 236       return PERL_constant_NOTDEF;
 237 #endif
 238     }
 239     break;
 240   }
 241   return PERL_constant_NOTFOUND;
 242 }
 243
 244 MODULE = GDBM_File      PACKAGE = GDBM_File     PREFIX = gdbm_
 245
 246 void
 247 constant(sv)
 248     PREINIT:
 249         dXSTARG;
 250         STRLEN          len;
 251         int             type;
 252         IV              iv;
 253         /* NV           nv;     Uncomment this if you need to return NVs */
 254         /* const char   *pv;    Uncomment this if you need to return PVs */
 255     INPUT:
 256         SV *            sv;
 257         const char *    s = SvPV(sv, len);
 258     PPCODE:
 259         /* Change this to constant(s, len, &iv, &nv);
 260            if you need to return both NVs and IVs */
 261         type = constant(s, len, &iv);
 262       /* Return 1 or 2 items. First is error message, or undef if no error.
 263            Second, if present, is found value */
 264         switch (type) {
 265         case PERL_constant_NOTFOUND:
 266           sv = sv_2mortal(newSVpvf("%s is not a valid GDBM_File macro", s));
 267           PUSHs(sv);
 268           break;
 269         case PERL_constant_NOTDEF:
 270           sv = sv_2mortal(newSVpvf(
 271             "Your vendor has not defined GDBM_File macro %s, used", s));
 272           PUSHs(sv);
 273           break;
 274         case PERL_constant_ISIV:
 275           EXTEND(SP, 1);
 276           PUSHs(&PL_sv_undef);
 277           PUSHi(iv);
 278           break;
 279         default:
 280           sv = sv_2mortal(newSVpvf(
 281             "Unexpected return type %d while processing GDBM_File macro %s, used",
 282                type, s));
 283           PUSHs(sv);
 284         }
 285
 286
 287 GDBM_File
 288 gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
 289         char *          dbtype
 290         char *          name
 291         int             read_write
 292         int             mode
 293         FATALFUNC       fatal_func
 294         CODE:
 295         {
 296             GDBM_FILE   dbp ;
 297
 298             RETVAL = NULL ;
 299             if ((dbp =  gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func))) {
 300                 RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
 301                 Zero(RETVAL, 1, GDBM_File_type) ;
 302                 RETVAL->dbp = dbp ;
 303             }
 304
 305         }
 306         OUTPUT:
 307           RETVAL
 308
 309
 310 #define gdbm_close(db)                  gdbm_close(db->dbp)
 311 void
 312 gdbm_close(db)
 313         GDBM_File       db
 314         CLEANUP:
 315
 316 void
 317 gdbm_DESTROY(db)
 318         GDBM_File       db
 319         CODE:
 320         gdbm_close(db);
 321         safefree(db);
 322
 323 #define gdbm_FETCH(db,key)                      gdbm_fetch(db->dbp,key)
 324 datum_value
 325 gdbm_FETCH(db, key)
 326         GDBM_File       db
 327         datum_key       key
 328
 329 #define gdbm_STORE(db,key,value,flags)          gdbm_store(db->dbp,key,value,flags)
 330 int
 331 gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
 332         GDBM_File       db
 333         datum_key       key
 334         datum_value     value
 335         int             flags
 336     CLEANUP:
 337         if (RETVAL) {
 338             if (RETVAL < 0 && errno == EPERM)
 339                 croak("No write permission to gdbm file");
 340             croak("gdbm store returned %d, errno %d, key \"%.*s\"",
 341                         RETVAL,errno,key.dsize,key.dptr);
 342         }
 343
 344 #define gdbm_DELETE(db,key)                     gdbm_delete(db->dbp,key)
 345 int
 346 gdbm_DELETE(db, key)
 347         GDBM_File       db
 348         datum_key       key
 349
 350 #define gdbm_FIRSTKEY(db)                       gdbm_firstkey(db->dbp)
 351 datum_key
 352 gdbm_FIRSTKEY(db)
 353         GDBM_File       db
 354
 355 #define gdbm_NEXTKEY(db,key)                    gdbm_nextkey(db->dbp,key)
 356 datum_key
 357 gdbm_NEXTKEY(db, key)
 358         GDBM_File       db
 359         datum_key       key
 360
 361 #define gdbm_reorganize(db)                     gdbm_reorganize(db->dbp)
 362 int
 363 gdbm_reorganize(db)
 364         GDBM_File       db
 365
 366
 367 #define gdbm_sync(db)                           gdbm_sync(db->dbp)
 368 void
 369 gdbm_sync(db)
 370         GDBM_File       db
 371
 372 #define gdbm_EXISTS(db,key)                     gdbm_exists(db->dbp,key)
 373 int
 374 gdbm_EXISTS(db, key)
 375         GDBM_File       db
 376         datum_key       key
 377
 378 #define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
 379 int
 380 gdbm_setopt (db, optflag, optval, optlen)
 381         GDBM_File       db
 382         int             optflag
 383         int             &optval
 384         int             optlen
 385
 386
 387 #define setFilter(type)                                 \
 388         {                                               \
 389             if (db->type)                               \
 390                 RETVAL = sv_mortalcopy(db->type) ;      \
 391             ST(0) = RETVAL ;                            \
 392             if (db->type && (code == &PL_sv_undef)) {   \
 393                 SvREFCNT_dec(db->type) ;                \
 394                 db->type = NULL ;                       \
 395             }                                           \
 396             else if (code) {                            \
 397                 if (db->type)                           \
 398                     sv_setsv(db->type, code) ;          \
 399                 else                                    \
 400                     db->type = newSVsv(code) ;          \
 401             }                                           \
 402         }
 403
 404
 405
 406 SV *
 407 filter_fetch_key(db, code)
 408         GDBM_File       db
 409         SV *            code
 410         SV *            RETVAL = &PL_sv_undef ;
 411         CODE:
 412             setFilter(filter_fetch_key) ;
 413
 414 SV *
 415 filter_store_key(db, code)
 416         GDBM_File       db
 417         SV *            code
 418         SV *            RETVAL =  &PL_sv_undef ;
 419         CODE:
 420             setFilter(filter_store_key) ;
 421
 422 SV *
 423 filter_fetch_value(db, code)
 424         GDBM_File       db
 425         SV *            code
 426         SV *            RETVAL =  &PL_sv_undef ;
 427         CODE:
 428             setFilter(filter_fetch_value) ;
 429
 430 SV *
 431 filter_store_value(db, code)
 432         GDBM_File       db
 433         SV *            code
 434         SV *            RETVAL =  &PL_sv_undef ;
 435         CODE:
 436             setFilter(filter_store_value) ;
 437