Stash.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 #define NEED_newRV_noinc
   6 #define NEED_sv_2pv_flags
   7 #include "ppport.h"
   8
   9 #ifndef gv_fetchsv
  10 #define gv_fetchsv(n,f,t) gv_fetchpv(SvPV_nolen(n), f, t)
  11 #endif
  12
  13 #ifndef mro_method_changed_in
  14 #define mro_method_changed_in(x) PL_sub_generation++
  15 #endif
  16
  17 #ifdef newSVhek
  18 #define newSVhe(he) newSVhek(HeKEY_hek(he))
  19 #else
  20 #define newSVhe(he) newSVpvn(HePV(he))
  21 #endif
  22
  23 #ifndef savesvpv
  24 #define savesvpv(s) savepv(SvPV_nolen(s))
  25 #endif
  26
  27 typedef enum {
  28     VAR_NONE = 0,
  29     VAR_SCALAR,
  30     VAR_ARRAY,
  31     VAR_HASH,
  32     VAR_CODE,
  33     VAR_IO,
  34     VAR_GLOB,  /* TODO: unimplemented */
  35     VAR_FORMAT /* TODO: unimplemented */
  36 } vartype_t;
  37
  38 typedef struct {
  39     vartype_t type;
  40     char sigil;
  41     char *name;
  42 } varspec_t;
  43
  44 const char *vartype_to_string(vartype_t type)
  45 {
  46     switch (type) {
  47     case VAR_SCALAR:
  48         return "SCALAR";
  49     case VAR_ARRAY:
  50         return "ARRAY";
  51     case VAR_HASH:
  52         return "HASH";
  53     case VAR_CODE:
  54         return "CODE";
  55     case VAR_IO:
  56         return "IO";
  57     default:
  58         return "unknown";
  59     }
  60 }
  61
  62 I32 vartype_to_svtype(vartype_t type)
  63 {
  64     switch (type) {
  65     case VAR_SCALAR:
  66         return SVt_PV; /* or whatever */
  67     case VAR_ARRAY:
  68         return SVt_PVAV;
  69     case VAR_HASH:
  70         return SVt_PVHV;
  71     case VAR_CODE:
  72         return SVt_PVCV;
  73     case VAR_IO:
  74         return SVt_PVIO;
  75     default:
  76         return SVt_NULL;
  77     }
  78 }
  79
  80 vartype_t string_to_vartype(char *vartype)
  81 {
  82     if (strEQ(vartype, "SCALAR")) {
  83         return VAR_SCALAR;
  84     }
  85     else if (strEQ(vartype, "ARRAY")) {
  86         return VAR_ARRAY;
  87     }
  88     else if (strEQ(vartype, "HASH")) {
  89         return VAR_HASH;
  90     }
  91     else if (strEQ(vartype, "CODE")) {
  92         return VAR_CODE;
  93     }
  94     else if (strEQ(vartype, "IO")) {
  95         return VAR_IO;
  96     }
  97     else {
  98         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
  99     }
 100 }
 101
 102 void _deconstruct_variable_name(char *variable, varspec_t *varspec)
 103 {
 104     if (!variable || !variable[0])
 105         croak("You must pass a variable name");
 106
 107     varspec->type = VAR_NONE;
 108
 109     switch (variable[0]) {
 110     case '$':
 111         varspec->type = VAR_SCALAR;
 112         break;
 113     case '@':
 114         varspec->type = VAR_ARRAY;
 115         break;
 116     case '%':
 117         varspec->type = VAR_HASH;
 118         break;
 119     case '&':
 120         varspec->type = VAR_CODE;
 121         break;
 122     }
 123
 124     if (varspec->type != VAR_NONE) {
 125         varspec->sigil = variable[0];
 126         varspec->name = &variable[1];
 127     }
 128     else {
 129         varspec->type = VAR_IO;
 130         varspec->sigil = '\0';
 131         varspec->name = variable;
 132     }
 133 }
 134
 135 void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
 136 {
 137     SV **val;
 138
 139     val = hv_fetch(variable, "name", 4, 0);
 140     if (!val)
 141         croak("The 'name' key is required in variable specs");
 142
 143     varspec->name = savesvpv(*val);
 144     SAVEFREEPV(varspec->name);
 145
 146     val = hv_fetch(variable, "sigil", 5, 0);
 147     if (!val)
 148         croak("The 'sigil' key is required in variable specs");
 149
 150     varspec->sigil = (SvPV_nolen(*val))[0];
 151
 152     val = hv_fetch(variable, "type", 4, 0);
 153     if (!val)
 154         croak("The 'type' key is required in variable specs");
 155
 156     varspec->type = string_to_vartype(SvPV_nolen(*val));
 157 }
 158
 159 int _valid_for_type(SV *value, vartype_t type)
 160 {
 161     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 162
 163     switch (type) {
 164     case VAR_SCALAR:
 165         return sv_type == SVt_NULL ||
 166                sv_type == SVt_IV   ||
 167                sv_type == SVt_NV   ||
 168                sv_type == SVt_PV   ||
 169                sv_type == SVt_RV;
 170     case VAR_ARRAY:
 171         return sv_type == SVt_PVAV;
 172     case VAR_HASH:
 173         return sv_type == SVt_PVHV;
 174     case VAR_CODE:
 175         return sv_type == SVt_PVCV;
 176     case VAR_IO:
 177         return sv_type == SVt_PVIO;
 178     default:
 179         return 0;
 180     }
 181 }
 182
 183 HV *_get_namespace(SV *self)
 184 {
 185     dSP;
 186     SV *ret;
 187
 188     PUSHMARK(SP);
 189     XPUSHs(self);
 190     PUTBACK;
 191
 192     call_method("namespace", G_SCALAR);
 193
 194     SPAGAIN;
 195     ret = POPs;
 196     PUTBACK;
 197
 198     return (HV*)SvRV(ret);
 199 }
 200
 201 SV *_get_name(SV *self)
 202 {
 203     dSP;
 204     SV *ret;
 205
 206     PUSHMARK(SP);
 207     XPUSHs(self);
 208     PUTBACK;
 209
 210     call_method("name", G_SCALAR);
 211
 212     SPAGAIN;
 213     ret = POPs;
 214     PUTBACK;
 215
 216     return ret;
 217 }
 218
 219 SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 220 {
 221     HV *namespace;
 222     SV **entry;
 223     GV *glob;
 224
 225     namespace = _get_namespace(self);
 226     entry = hv_fetch(namespace, variable->name, strlen(variable->name), vivify);
 227     if (!entry)
 228         return NULL;
 229
 230     glob = (GV*)(*entry);
 231     if (!isGV(glob)) {
 232         SV *namesv;
 233
 234         namesv = newSVsv(_get_name(self));
 235         sv_catpvs(namesv, "::");
 236         sv_catpv(namesv, variable->name);
 237
 238         /* can't use gv_init here, because it screws up @ISA in a way that I
 239          * can't reproduce, but that CMOP triggers */
 240         gv_fetchsv(namesv, GV_ADD, vartype_to_svtype(variable->type));
 241         SvREFCNT_dec(namesv);
 242     }
 243
 244     if (vivify) {
 245         switch (variable->type) {
 246         case VAR_SCALAR:
 247             if (!GvSV(glob))
 248                 GvSV(glob) = newSV(0);
 249             break;
 250         case VAR_ARRAY:
 251             if (!GvAV(glob))
 252                 GvAV(glob) = newAV();
 253             break;
 254         case VAR_HASH:
 255             if (!GvHV(glob))
 256                 GvHV(glob) = newHV();
 257             break;
 258         case VAR_CODE:
 259             croak("Don't know how to vivify CODE variables");
 260         case VAR_IO:
 261             if (!GvIO(glob))
 262                 GvIOp(glob) = newIO();
 263             break;
 264         default:
 265             croak("Unknown type in vivication");
 266         }
 267     }
 268
 269     switch (variable->type) {
 270     case VAR_SCALAR:
 271         return GvSV(glob);
 272     case VAR_ARRAY:
 273         return (SV*)GvAV(glob);
 274     case VAR_HASH:
 275         return (SV*)GvHV(glob);
 276     case VAR_CODE:
 277         return (SV*)GvCV(glob);
 278     case VAR_IO:
 279         return (SV*)GvIO(glob);
 280     default:
 281         return NULL;
 282     }
 283 }
 284
 285 MODULE = Package::Stash  PACKAGE = Package::Stash
 286
 287 PROTOTYPES: DISABLE
 288
 289 SV*
 290 new(class, package_name)
 291     char *class
 292     SV *package_name
 293   PREINIT:
 294     HV *instance;
 295     HV *namespace;
 296     SV *nsref;
 297   CODE:
 298     if (!SvPOK(package_name))
 299         croak("The constructor argument must be the name of a package");
 300
 301     instance = newHV();
 302
 303     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
 304         SvREFCNT_dec(package_name);
 305         SvREFCNT_dec(instance);
 306         croak("Couldn't initialize the 'name' key, hv_store failed");
 307     }
 308     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 309     nsref = newRV_inc((SV*)namespace);
 310     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
 311         SvREFCNT_dec(nsref);
 312         SvREFCNT_dec(instance);
 313         croak("Couldn't initialize the 'namespace' key, hv_store failed");
 314     }
 315
 316     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
 317   OUTPUT:
 318     RETVAL
 319
 320 SV*
 321 name(self)
 322     SV *self
 323   PREINIT:
 324     SV **slot;
 325   CODE:
 326     if (!sv_isobject(self))
 327         croak("Can't call name as a class method");
 328     slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
 329     RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
 330   OUTPUT:
 331     RETVAL
 332
 333 SV*
 334 namespace(self)
 335     SV *self
 336   PREINIT:
 337     SV **slot;
 338   CODE:
 339     if (!sv_isobject(self))
 340         croak("Can't call namespace as a class method");
 341     slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
 342     RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
 343   OUTPUT:
 344     RETVAL
 345
 346 void
 347 add_symbol(self, variable, initial=NULL, ...)
 348     SV *self
 349     varspec_t variable
 350     SV *initial
 351   PREINIT:
 352     SV *name;
 353     GV *glob;
 354   CODE:
 355     if (initial && !_valid_for_type(initial, variable.type))
 356         croak("%s is not of type %s",
 357               SvPV_nolen(initial), vartype_to_string(variable.type));
 358
 359     name = newSVsv(_get_name(self));
 360     sv_catpvs(name, "::");
 361     sv_catpv(name, variable.name);
 362
 363     /* XXX: come back to this when i feel like reimplementing caller() */
 364 /*
 365     my $filename = $opts{filename};
 366     my $first_line_num = $opts{first_line_num};
 367
 368     (undef, $filename, $first_line_num) = caller
 369         if not defined $filename;
 370
 371     my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 372
 373     # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 374     $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 375 */
 376 /*
 377     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 378         int i;
 379         char *filename = NULL, *name;
 380         I32 first_line_num, last_line_num;
 381
 382         if ((items - 3) % 2)
 383             croak("add_symbol: Odd number of elements in %%opts");
 384
 385         for (i = 3; i < items; i += 2) {
 386             char *key;
 387             key = SvPV_nolen(ST(i));
 388             if (strEQ(key, "filename")) {
 389                 if (!SvPOK(ST(i + 1)))
 390                     croak("add_symbol: filename must be a string");
 391                 filename = SvPV_nolen(ST(i + 1));
 392             }
 393             else if (strEQ(key, "first_line_num")) {
 394                 if (!SvIOK(ST(i + 1)))
 395                     croak("add_symbol: first_line_num must be an integer");
 396                 first_line_num = SvIV(ST(i + 1));
 397             }
 398             else if (strEQ(key, "last_line_num")) {
 399                 if (!SvIOK(ST(i + 1)))
 400                     croak("add_symbol: last_line_num must be an integer");
 401                 last_line_num = SvIV(ST(i + 1));
 402             }
 403         }
 404
 405         if (!filename) {
 406         }
 407     }
 408 */
 409
 410     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
 411
 412     if (initial) {
 413         SV *val;
 414
 415         if (SvROK(initial)) {
 416             val = SvRV(initial);
 417             SvREFCNT_inc_simple_void_NN(val);
 418         }
 419         else {
 420             val = newSVsv(initial);
 421         }
 422
 423         switch (variable.type) {
 424         case VAR_SCALAR:
 425             SvREFCNT_dec(GvSV(glob));
 426             GvSV(glob) = val;
 427             GvIMPORTED_SV_on(glob);
 428             break;
 429         case VAR_ARRAY:
 430             SvREFCNT_dec(GvAV(glob));
 431             GvAV(glob) = (AV*)val;
 432             GvIMPORTED_AV_on(glob);
 433             break;
 434         case VAR_HASH:
 435             SvREFCNT_dec(GvHV(glob));
 436             GvHV(glob) = (HV*)val;
 437             GvIMPORTED_HV_on(glob);
 438             break;
 439         case VAR_CODE:
 440             SvREFCNT_dec(GvCV(glob));
 441             GvCV(glob) = (CV*)val;
 442             GvIMPORTED_CV_on(glob);
 443             GvASSUMECV_on(glob);
 444             GvCVGEN(glob) = 0;
 445             mro_method_changed_in(GvSTASH(glob));
 446             break;
 447         case VAR_IO:
 448             SvREFCNT_dec(GvIO(glob));
 449             GvIOp(glob) = (IO*)val;
 450             break;
 451         }
 452     }
 453
 454     SvREFCNT_dec(name);
 455
 456 void
 457 remove_glob(self, name)
 458     SV *self
 459     char *name
 460   CODE:
 461     hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
 462
 463 int
 464 has_symbol(self, variable)
 465     SV *self
 466     varspec_t variable
 467   PREINIT:
 468     HV *namespace;
 469     SV **entry;
 470   CODE:
 471     namespace = _get_namespace(self);
 472     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 473     if (!entry)
 474         XSRETURN_UNDEF;
 475
 476     if (isGV(*entry)) {
 477         GV *glob = (GV*)(*entry);
 478         switch (variable.type) {
 479         case VAR_SCALAR:
 480             RETVAL = GvSV(glob) ? 1 : 0;
 481             break;
 482         case VAR_ARRAY:
 483             RETVAL = GvAV(glob) ? 1 : 0;
 484             break;
 485         case VAR_HASH:
 486             RETVAL = GvHV(glob) ? 1 : 0;
 487             break;
 488         case VAR_CODE:
 489             RETVAL = GvCV(glob) ? 1 : 0;
 490             break;
 491         case VAR_IO:
 492             RETVAL = GvIO(glob) ? 1 : 0;
 493             break;
 494         }
 495     }
 496     else {
 497         RETVAL = (variable.type == VAR_CODE);
 498     }
 499   OUTPUT:
 500     RETVAL
 501
 502 SV*
 503 get_symbol(self, variable)
 504     SV *self
 505     varspec_t variable
 506   PREINIT:
 507     SV *val;
 508   CODE:
 509     val = _get_symbol(self, &variable, 0);
 510     if (!val)
 511         XSRETURN_UNDEF;
 512     RETVAL = newRV_inc(val);
 513   OUTPUT:
 514     RETVAL
 515
 516 SV*
 517 get_or_add_symbol(self, variable)
 518     SV *self
 519     varspec_t variable
 520   PREINIT:
 521     SV *val;
 522   CODE:
 523     val = _get_symbol(self, &variable, 1);
 524     if (!val)
 525         XSRETURN_UNDEF;
 526     RETVAL = newRV_inc(val);
 527   OUTPUT:
 528     RETVAL
 529
 530 void
 531 remove_symbol(self, variable)
 532     SV *self
 533     varspec_t variable
 534   PREINIT:
 535     HV *namespace;
 536     SV **entry;
 537   CODE:
 538     namespace = _get_namespace(self);
 539     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 540     if (!entry)
 541         XSRETURN_EMPTY;
 542
 543     if (isGV(*entry)) {
 544         GV *glob = (GV*)(*entry);
 545         switch (variable.type) {
 546         case VAR_SCALAR:
 547             GvSV(glob) = (SV *)NULL;
 548             break;
 549         case VAR_ARRAY:
 550             GvAV(glob) = (AV *)NULL;
 551             break;
 552         case VAR_HASH:
 553             GvHV(glob) = (HV *)NULL;
 554             break;
 555         case VAR_CODE:
 556             GvCV(glob) = (CV *)NULL;
 557             GvCVGEN(glob) = 0;
 558             mro_method_changed_in(GvSTASH(glob));
 559             break;
 560         case VAR_IO:
 561             GvIOp(glob) = (IO *)NULL;
 562             break;
 563         }
 564     }
 565     else {
 566         if (variable.type == VAR_CODE) {
 567             hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
 568         }
 569     }
 570
 571 void
 572 list_all_symbols(self, vartype=VAR_NONE)
 573     SV *self
 574     vartype_t vartype
 575   PPCODE:
 576     if (vartype == VAR_NONE) {
 577         HV *namespace;
 578         HE *entry;
 579         int keys;
 580
 581         namespace = _get_namespace(self);
 582         keys = hv_iterinit(namespace);
 583         EXTEND(SP, keys);
 584         while ((entry = hv_iternext(namespace))) {
 585             mPUSHs(newSVhe(entry));
 586         }
 587     }
 588     else {
 589         HV *namespace;
 590         SV *val;
 591         char *key;
 592         int len;
 593
 594         namespace = _get_namespace(self);
 595         hv_iterinit(namespace);
 596         while ((val = hv_iternextsv(namespace, &key, &len))) {
 597             GV *gv = (GV*)val;
 598             if (isGV(gv)) {
 599                 switch (vartype) {
 600                 case VAR_SCALAR:
 601                     if (GvSV(val))
 602                         mXPUSHp(key, len);
 603                     break;
 604                 case VAR_ARRAY:
 605                     if (GvAV(val))
 606                         mXPUSHp(key, len);
 607                     break;
 608                 case VAR_HASH:
 609                     if (GvHV(val))
 610                         mXPUSHp(key, len);
 611                     break;
 612                 case VAR_CODE:
 613                     if (GvCVu(val))
 614                         mXPUSHp(key, len);
 615                     break;
 616                 case VAR_IO:
 617                     if (GvIO(val))
 618                         mXPUSHp(key, len);
 619                     break;
 620                 }
 621             }
 622             else if (vartype == VAR_CODE) {
 623                 mXPUSHp(key, len);
 624             }
 625         }
 626     }