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