pod coverage, eol whitespace
[gitmo/Package-Stash-XS.git] / XS.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) newSVpv(HePV(he, PL_na), 0)
21 #endif
22
23 #ifndef savesvpv
24 #define savesvpv(s) savepv(SvPV_nolen(s))
25 #endif
26
27 /* HACK: scalar slots are always populated on perl < 5.10, so treat undef
28  * as nonexistent. this is consistent with the previous behavior of the pure
29  * perl version of this module (since this is the behavior that perl sees
30  * in all versions */
31 #if PERL_VERSION < 10
32 #define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL)
33 #else
34 #define GvSVOK(g) GvSV(g)
35 #endif
36
37 #define GvAVOK(g) GvAV(g)
38 #define GvHVOK(g) GvHV(g)
39 #define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */
40 #define GvIOOK(g) GvIO(g)
41
42 /* see above - don't let scalar slots become unpopulated, this breaks
43  * assumptions in core */
44 #if PERL_VERSION < 10
45 #define GvSetSV(g,v) do {               \
46     SV *_v = (SV*)(v);                  \
47     SvREFCNT_dec(GvSV(g));              \
48     if ((GvSV(g) = _v ? _v : newSV(0))) \
49         GvIMPORTED_SV_on(g);            \
50 } while (0)
51 #else
52 #define GvSetSV(g,v) do {               \
53     SvREFCNT_dec(GvSV(g));              \
54     if ((GvSV(g) = (SV*)(v)))           \
55         GvIMPORTED_SV_on(g);            \
56 } while (0)
57 #endif
58
59 #define GvSetAV(g,v) do {               \
60     SvREFCNT_dec(GvAV(g));              \
61     if ((GvAV(g) = (AV*)(v)))           \
62         GvIMPORTED_AV_on(g);            \
63 } while (0)
64 #define GvSetHV(g,v) do {               \
65     SvREFCNT_dec(GvHV(g));              \
66     if ((GvHV(g) = (HV*)(v)))           \
67         GvIMPORTED_HV_on(g);            \
68 } while (0)
69 #define GvSetCV(g,v) do {               \
70     SvREFCNT_dec(GvCV(g));              \
71     if ((GvCV(g) = (CV*)(v))) {         \
72         GvIMPORTED_CV_on(g);            \
73         GvASSUMECV_on(g);               \
74     }                                   \
75     GvCVGEN(g) = 0;                     \
76     mro_method_changed_in(GvSTASH(g));  \
77 } while (0)
78 #define GvSetIO(g,v) do {               \
79     SvREFCNT_dec(GvIO(g));              \
80     GvIOp(g) = (IO*)(v);                \
81 } while (0)
82
83 typedef enum {
84     VAR_NONE = 0,
85     VAR_SCALAR,
86     VAR_ARRAY,
87     VAR_HASH,
88     VAR_CODE,
89     VAR_IO,
90     VAR_GLOB,  /* TODO: unimplemented */
91     VAR_FORMAT /* TODO: unimplemented */
92 } vartype_t;
93
94 typedef struct {
95     vartype_t type;
96     SV *name;
97 } varspec_t;
98
99 static U32 name_hash, namespace_hash, type_hash;
100 static SV *name_key, *namespace_key, *type_key;
101
102 const char *vartype_to_string(vartype_t type)
103 {
104     switch (type) {
105     case VAR_SCALAR:
106         return "SCALAR";
107     case VAR_ARRAY:
108         return "ARRAY";
109     case VAR_HASH:
110         return "HASH";
111     case VAR_CODE:
112         return "CODE";
113     case VAR_IO:
114         return "IO";
115     default:
116         return "unknown";
117     }
118 }
119
120 I32 vartype_to_svtype(vartype_t type)
121 {
122     switch (type) {
123     case VAR_SCALAR:
124         return SVt_PV; /* or whatever */
125     case VAR_ARRAY:
126         return SVt_PVAV;
127     case VAR_HASH:
128         return SVt_PVHV;
129     case VAR_CODE:
130         return SVt_PVCV;
131     case VAR_IO:
132         return SVt_PVIO;
133     default:
134         return SVt_NULL;
135     }
136 }
137
138 vartype_t string_to_vartype(char *vartype)
139 {
140     if (strEQ(vartype, "SCALAR")) {
141         return VAR_SCALAR;
142     }
143     else if (strEQ(vartype, "ARRAY")) {
144         return VAR_ARRAY;
145     }
146     else if (strEQ(vartype, "HASH")) {
147         return VAR_HASH;
148     }
149     else if (strEQ(vartype, "CODE")) {
150         return VAR_CODE;
151     }
152     else if (strEQ(vartype, "IO")) {
153         return VAR_IO;
154     }
155     else {
156         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
157     }
158 }
159
160 void _deconstruct_variable_name(SV *variable, varspec_t *varspec)
161 {
162     char *varpv;
163
164     if (!SvCUR(variable))
165         croak("You must pass a variable name");
166
167     varspec->name = sv_2mortal(newSVsv(variable));
168
169     varpv = SvPV_nolen(varspec->name);
170     switch (varpv[0]) {
171     case '$':
172         varspec->type = VAR_SCALAR;
173         sv_chop(varspec->name, &varpv[1]);
174         break;
175     case '@':
176         varspec->type = VAR_ARRAY;
177         sv_chop(varspec->name, &varpv[1]);
178         break;
179     case '%':
180         varspec->type = VAR_HASH;
181         sv_chop(varspec->name, &varpv[1]);
182         break;
183     case '&':
184         varspec->type = VAR_CODE;
185         sv_chop(varspec->name, &varpv[1]);
186         break;
187     default:
188         varspec->type = VAR_IO;
189         break;
190     }
191 }
192
193 void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
194 {
195     HE *val;
196     STRLEN len;
197
198     val = hv_fetch_ent(variable, name_key, 0, name_hash);
199     if (!val)
200         croak("The 'name' key is required in variable specs");
201
202     varspec->name = sv_2mortal(newSVhe(val));
203
204     val = hv_fetch_ent(variable, type_key, 0, type_hash);
205     if (!val)
206         croak("The 'type' key is required in variable specs");
207
208     varspec->type = string_to_vartype(HePV(val, len));
209 }
210
211 int _valid_for_type(SV *value, vartype_t type)
212 {
213     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
214
215     switch (type) {
216     case VAR_SCALAR:
217         return sv_type == SVt_NULL ||
218                sv_type == SVt_IV   ||
219                sv_type == SVt_NV   ||
220                sv_type == SVt_PV   ||
221                sv_type == SVt_RV;
222     case VAR_ARRAY:
223         return sv_type == SVt_PVAV;
224     case VAR_HASH:
225         return sv_type == SVt_PVHV;
226     case VAR_CODE:
227         return sv_type == SVt_PVCV;
228     case VAR_IO:
229         return sv_type == SVt_PVIO;
230     default:
231         return 0;
232     }
233 }
234
235 HV *_get_namespace(SV *self)
236 {
237     dSP;
238     SV *ret;
239
240     PUSHMARK(SP);
241     XPUSHs(self);
242     PUTBACK;
243
244     call_method("namespace", G_SCALAR);
245
246     SPAGAIN;
247     ret = POPs;
248     PUTBACK;
249
250     return (HV*)SvRV(ret);
251 }
252
253 SV *_get_name(SV *self)
254 {
255     dSP;
256     SV *ret;
257
258     PUSHMARK(SP);
259     XPUSHs(self);
260     PUTBACK;
261
262     call_method("name", G_SCALAR);
263
264     SPAGAIN;
265     ret = POPs;
266     PUTBACK;
267
268     return ret;
269 }
270
271 void _expand_glob(SV *self, SV *varname)
272 {
273     SV *name;
274
275     name = newSVsv(_get_name(self));
276     sv_catpvs(name, "::");
277     sv_catsv(name, varname);
278
279     /* can't use gv_init here, because it screws up @ISA in a way that I
280      * can't reproduce, but that CMOP triggers */
281     gv_fetchsv(name, GV_ADD, SVt_NULL);
282     SvREFCNT_dec(name);
283 }
284
285 SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
286 {
287     HV *namespace;
288     HE *entry;
289     GV *glob;
290
291     namespace = _get_namespace(self);
292     entry = hv_fetch_ent(namespace, variable->name, vivify, 0);
293     if (!entry)
294         return NULL;
295
296     glob = (GV*)(HeVAL(entry));
297     if (!isGV(glob))
298         _expand_glob(self, variable->name);
299
300     if (vivify) {
301         switch (variable->type) {
302         case VAR_SCALAR:
303             if (!GvSVOK(glob))
304                 GvSetSV(glob, newSV(0));
305             break;
306         case VAR_ARRAY:
307             if (!GvAVOK(glob))
308                 GvSetAV(glob, newAV());
309             break;
310         case VAR_HASH:
311             if (!GvHVOK(glob))
312                 GvSetHV(glob, newHV());
313             break;
314         case VAR_CODE:
315             croak("Don't know how to vivify CODE variables");
316         case VAR_IO:
317             if (!GvIOOK(glob))
318                 GvSetIO(glob, newIO());
319             break;
320         default:
321             croak("Unknown type in vivication");
322         }
323     }
324
325     switch (variable->type) {
326     case VAR_SCALAR:
327         return GvSV(glob);
328     case VAR_ARRAY:
329         return (SV*)GvAV(glob);
330     case VAR_HASH:
331         return (SV*)GvHV(glob);
332     case VAR_CODE:
333         return (SV*)GvCV(glob);
334     case VAR_IO:
335         return (SV*)GvIO(glob);
336     default:
337         return NULL;
338     }
339 }
340
341 MODULE = Package::Stash::XS  PACKAGE = Package::Stash::XS
342
343 PROTOTYPES: DISABLE
344
345 SV*
346 new(class, package_name)
347     SV *class
348     SV *package_name
349   PREINIT:
350     HV *instance;
351     HV *namespace;
352     SV *nsref;
353   CODE:
354     if (!SvPOK(package_name))
355         croak("The constructor argument must be the name of a package");
356
357     instance = newHV();
358
359     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
360         SvREFCNT_dec(package_name);
361         SvREFCNT_dec(instance);
362         croak("Couldn't initialize the 'name' key, hv_store failed");
363     }
364     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
365     nsref = newRV_inc((SV*)namespace);
366     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
367         SvREFCNT_dec(nsref);
368         SvREFCNT_dec(instance);
369         croak("Couldn't initialize the 'namespace' key, hv_store failed");
370     }
371
372     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
373   OUTPUT:
374     RETVAL
375
376 SV*
377 name(self)
378     SV *self
379   PREINIT:
380     HE *slot;
381   CODE:
382     if (!sv_isobject(self))
383         croak("Can't call name as a class method");
384     slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
385     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
386   OUTPUT:
387     RETVAL
388
389 SV*
390 namespace(self)
391     SV *self
392   PREINIT:
393     HE *slot;
394   CODE:
395     if (!sv_isobject(self))
396         croak("Can't call namespace as a class method");
397     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
398     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
399   OUTPUT:
400     RETVAL
401
402 void
403 add_symbol(self, variable, initial=NULL, ...)
404     SV *self
405     varspec_t variable
406     SV *initial
407   PREINIT:
408     SV *name;
409     GV *glob;
410   CODE:
411     if (initial && !_valid_for_type(initial, variable.type))
412         croak("%s is not of type %s",
413               SvPV_nolen(initial), vartype_to_string(variable.type));
414
415     name = newSVsv(_get_name(self));
416     sv_catpvs(name, "::");
417     sv_catsv(name, variable.name);
418
419     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
420         int i;
421         char *filename = NULL;
422         I32 first_line_num = -1, last_line_num = -1;
423         STRLEN namelen;
424         SV *dbval;
425         HV *dbsub;
426
427         if ((items - 3) % 2)
428             croak("add_symbol: Odd number of elements in %%opts");
429
430         for (i = 3; i < items; i += 2) {
431             char *key;
432             key = SvPV_nolen(ST(i));
433             if (strEQ(key, "filename")) {
434                 if (!SvPOK(ST(i + 1)))
435                     croak("add_symbol: filename must be a string");
436                 filename = SvPV_nolen(ST(i + 1));
437             }
438             else if (strEQ(key, "first_line_num")) {
439                 if (!SvIOK(ST(i + 1)))
440                     croak("add_symbol: first_line_num must be an integer");
441                 first_line_num = SvIV(ST(i + 1));
442             }
443             else if (strEQ(key, "last_line_num")) {
444                 if (!SvIOK(ST(i + 1)))
445                     croak("add_symbol: last_line_num must be an integer");
446                 last_line_num = SvIV(ST(i + 1));
447             }
448         }
449
450         if (!filename || first_line_num == -1) {
451             if (!filename)
452                 filename = CopFILE(PL_curcop);
453             if (first_line_num == -1)
454                 first_line_num = PL_curcop->cop_line;
455         }
456
457         if (last_line_num == -1)
458             last_line_num = first_line_num;
459
460         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
461         dbsub = get_hv("DB::sub", 1);
462         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
463         if (!hv_store_ent(dbsub, name, dbval, 0)) {
464             warn("Failed to update $DB::sub for subroutine %s",
465                  SvPV_nolen(name));
466             SvREFCNT_dec(dbval);
467         }
468     }
469
470     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
471      * once' warnings in some situations... i can't reproduce this, but CMOP
472      * triggers it */
473     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
474
475     if (initial) {
476         SV *val;
477
478         if (SvROK(initial)) {
479             val = SvRV(initial);
480             SvREFCNT_inc_simple_void_NN(val);
481         }
482         else {
483             val = newSVsv(initial);
484         }
485
486         switch (variable.type) {
487         case VAR_SCALAR:
488             GvSetSV(glob, val);
489             break;
490         case VAR_ARRAY:
491             GvSetAV(glob, val);
492             break;
493         case VAR_HASH:
494             GvSetHV(glob, val);
495             break;
496         case VAR_CODE:
497             GvSetCV(glob, val);
498             break;
499         case VAR_IO:
500             GvSetIO(glob, val);
501             break;
502         }
503     }
504
505     SvREFCNT_dec(name);
506
507 void
508 remove_glob(self, name)
509     SV *self
510     SV *name
511   CODE:
512     hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
513
514 int
515 has_symbol(self, variable)
516     SV *self
517     varspec_t variable
518   PREINIT:
519     HV *namespace;
520     HE *entry;
521     SV *val;
522   CODE:
523     namespace = _get_namespace(self);
524     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
525     if (!entry)
526         XSRETURN_UNDEF;
527
528     val = HeVAL(entry);
529     if (isGV(val)) {
530         GV *glob = (GV*)val;
531         switch (variable.type) {
532         case VAR_SCALAR:
533             RETVAL = GvSVOK(glob) ? 1 : 0;
534             break;
535         case VAR_ARRAY:
536             RETVAL = GvAVOK(glob) ? 1 : 0;
537             break;
538         case VAR_HASH:
539             RETVAL = GvHVOK(glob) ? 1 : 0;
540             break;
541         case VAR_CODE:
542             RETVAL = GvCVOK(glob) ? 1 : 0;
543             break;
544         case VAR_IO:
545             RETVAL = GvIOOK(glob) ? 1 : 0;
546             break;
547         }
548     }
549     else {
550         RETVAL = (variable.type == VAR_CODE);
551     }
552   OUTPUT:
553     RETVAL
554
555 SV*
556 get_symbol(self, variable)
557     SV *self
558     varspec_t variable
559   PREINIT:
560     SV *val;
561   CODE:
562     val = _get_symbol(self, &variable, 0);
563     if (!val)
564         XSRETURN_UNDEF;
565     RETVAL = newRV_inc(val);
566   OUTPUT:
567     RETVAL
568
569 SV*
570 get_or_add_symbol(self, variable)
571     SV *self
572     varspec_t variable
573   PREINIT:
574     SV *val;
575   CODE:
576     val = _get_symbol(self, &variable, 1);
577     if (!val)
578         XSRETURN_UNDEF;
579     RETVAL = newRV_inc(val);
580   OUTPUT:
581     RETVAL
582
583 void
584 remove_symbol(self, variable)
585     SV *self
586     varspec_t variable
587   PREINIT:
588     HV *namespace;
589     HE *entry;
590     SV *val;
591   CODE:
592     namespace = _get_namespace(self);
593     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
594     if (!entry)
595         XSRETURN_EMPTY;
596
597     val = HeVAL(entry);
598     if (isGV(val)) {
599         GV *glob = (GV*)val;
600         switch (variable.type) {
601         case VAR_SCALAR:
602             GvSetSV(glob, NULL);
603             break;
604         case VAR_ARRAY:
605             GvSetAV(glob, NULL);
606             break;
607         case VAR_HASH:
608             GvSetHV(glob, NULL);
609             break;
610         case VAR_CODE:
611             GvSetCV(glob, NULL);
612             break;
613         case VAR_IO:
614             GvSetIO(glob, NULL);
615             break;
616         }
617     }
618     else {
619         if (variable.type == VAR_CODE) {
620             hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
621         }
622     }
623
624 void
625 list_all_symbols(self, vartype=VAR_NONE)
626     SV *self
627     vartype_t vartype
628   PPCODE:
629     if (vartype == VAR_NONE) {
630         HV *namespace;
631         HE *entry;
632         int keys;
633
634         namespace = _get_namespace(self);
635         keys = hv_iterinit(namespace);
636         EXTEND(SP, keys);
637         while ((entry = hv_iternext(namespace))) {
638             mPUSHs(newSVhe(entry));
639         }
640     }
641     else {
642         HV *namespace;
643         SV *val;
644         char *key;
645         I32 len;
646
647         namespace = _get_namespace(self);
648         hv_iterinit(namespace);
649         while ((val = hv_iternextsv(namespace, &key, &len))) {
650             GV *gv = (GV*)val;
651             if (isGV(gv)) {
652                 switch (vartype) {
653                 case VAR_SCALAR:
654                     if (GvSVOK(val))
655                         mXPUSHp(key, len);
656                     break;
657                 case VAR_ARRAY:
658                     if (GvAVOK(val))
659                         mXPUSHp(key, len);
660                     break;
661                 case VAR_HASH:
662                     if (GvHVOK(val))
663                         mXPUSHp(key, len);
664                     break;
665                 case VAR_CODE:
666                     if (GvCVOK(val))
667                         mXPUSHp(key, len);
668                     break;
669                 case VAR_IO:
670                     if (GvIOOK(val))
671                         mXPUSHp(key, len);
672                     break;
673                 }
674             }
675             else if (vartype == VAR_CODE) {
676                 mXPUSHp(key, len);
677             }
678         }
679     }
680
681 void
682 get_all_symbols(self, vartype=VAR_NONE)
683     SV *self
684     vartype_t vartype
685   PREINIT:
686     HV *namespace, *ret;
687     SV *val;
688     char *key;
689     I32 len;
690   PPCODE:
691     namespace = _get_namespace(self);
692     ret = newHV();
693
694     hv_iterinit(namespace);
695     while ((val = hv_iternextsv(namespace, &key, &len))) {
696         GV *gv = (GV*)val;
697
698         if (!isGV(gv)) {
699             SV *keysv = newSVpvn(key, len);
700             _expand_glob(self, keysv);
701             SvREFCNT_dec(keysv);
702         }
703
704         switch (vartype) {
705         case VAR_SCALAR:
706             if (GvSVOK(val))
707                 hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
708             break;
709         case VAR_ARRAY:
710             if (GvAVOK(val))
711                 hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
712             break;
713         case VAR_HASH:
714             if (GvHVOK(val))
715                 hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
716             break;
717         case VAR_CODE:
718             if (GvCVOK(val))
719                 hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
720             break;
721         case VAR_IO:
722             if (GvIOOK(val))
723                 hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
724             break;
725         case VAR_NONE:
726             hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0);
727             break;
728         }
729     }
730
731     mPUSHs(newRV_noinc((SV*)ret));
732
733 BOOT:
734     {
735         name_key = newSVpvs("name");
736         PERL_HASH(name_hash, "name", 4);
737
738         namespace_key = newSVpvs("namespace");
739         PERL_HASH(namespace_hash, "namespace", 9);
740
741         type_key = newSVpvs("type");
742         PERL_HASH(type_hash, "type", 4);
743     }