| Commit | Line | Data |
|---|
| 59017825 |
1 | #include "EXTERN.h" |
| 2 | #include "perl.h" |
| 3 | #include "XSUB.h" |
| 4 | |
| a382a84b |
5 | typedef enum { |
| 6 | VAR_NONE = 0, |
| 7 | VAR_SCALAR, |
| 8 | VAR_ARRAY, |
| 9 | VAR_HASH, |
| 10 | VAR_CODE, |
| 11 | VAR_IO, |
| 12 | VAR_GLOB, /* TODO: unimplemented */ |
| 13 | VAR_FORMAT /* TODO: unimplemented */ |
| 14 | } vartype_t; |
| 15 | |
| 16 | typedef struct { |
| 17 | vartype_t type; |
| 18 | char sigil; |
| 19 | char *name; |
| 20 | } varspec_t; |
| 21 | |
| 22 | vartype_t string_to_vartype(char *vartype) |
| 23 | { |
| 24 | if (strEQ(vartype, "SCALAR")) { |
| 25 | return VAR_SCALAR; |
| 26 | } |
| 27 | else if (strEQ(vartype, "ARRAY")) { |
| 28 | return VAR_ARRAY; |
| 29 | } |
| 30 | else if (strEQ(vartype, "HASH")) { |
| 31 | return VAR_HASH; |
| 32 | } |
| 33 | else if (strEQ(vartype, "CODE")) { |
| 34 | return VAR_CODE; |
| 35 | } |
| 36 | else if (strEQ(vartype, "IO")) { |
| 37 | return VAR_IO; |
| 38 | } |
| 39 | else { |
| 40 | croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'"); |
| 41 | } |
| 42 | } |
| 43 | |
| 44 | void _deconstruct_variable_name(char *variable, varspec_t *varspec) |
| 45 | { |
| 46 | if (!variable || !variable[0]) |
| 47 | croak("You must pass a variable name"); |
| 48 | |
| 49 | varspec->type = VAR_NONE; |
| 50 | |
| 51 | switch (variable[0]) { |
| 52 | case '$': |
| 53 | varspec->type = VAR_SCALAR; |
| 54 | break; |
| 55 | case '@': |
| 56 | varspec->type = VAR_ARRAY; |
| 57 | break; |
| 58 | case '%': |
| 59 | varspec->type = VAR_HASH; |
| 60 | break; |
| 61 | case '&': |
| 62 | varspec->type = VAR_CODE; |
| 63 | break; |
| 64 | } |
| 65 | |
| 66 | if (varspec->type != VAR_NONE) { |
| 67 | varspec->sigil = variable[0]; |
| 68 | varspec->name = &variable[1]; |
| 69 | } |
| 70 | else { |
| 71 | varspec->type = VAR_IO; |
| 72 | varspec->sigil = '\0'; |
| 73 | varspec->name = variable; |
| 74 | } |
| 75 | } |
| 76 | |
| 77 | void _deconstruct_variable_hash(HV *variable, varspec_t *varspec) |
| 78 | { |
| 79 | SV **val; |
| 80 | char *type; |
| 81 | |
| 82 | val = hv_fetch(variable, "name", 4, 0); |
| 83 | if (!val) |
| 84 | croak("The 'name' key is required in variable specs"); |
| 85 | |
| 86 | varspec->name = savesvpv(*val); |
| 87 | |
| 88 | val = hv_fetch(variable, "sigil", 5, 0); |
| 89 | if (!val) |
| 90 | croak("The 'sigil' key is required in variable specs"); |
| 91 | |
| 92 | varspec->sigil = (SvPV_nolen(*val))[0]; |
| 93 | |
| 94 | val = hv_fetch(variable, "type", 4, 0); |
| 95 | if (!val) |
| 96 | croak("The 'type' key is required in variable specs"); |
| 97 | |
| 98 | varspec->type = string_to_vartype(SvPV_nolen(*val)); |
| 99 | } |
| 100 | |
| 101 | int _valid_for_type(SV *value, vartype_t type) |
| 102 | { |
| 103 | svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL; |
| 104 | |
| 105 | switch (type) { |
| 106 | case VAR_SCALAR: |
| 107 | return sv_type == SVt_NULL || |
| 108 | sv_type == SVt_IV || |
| 109 | sv_type == SVt_NV || |
| 110 | sv_type == SVt_PV || |
| 111 | sv_type == SVt_RV; |
| 112 | case VAR_ARRAY: |
| 113 | return sv_type == SVt_PVAV; |
| 114 | case VAR_HASH: |
| 115 | return sv_type == SVt_PVHV; |
| 116 | case VAR_CODE: |
| 117 | return sv_type == SVt_PVCV; |
| 118 | case VAR_IO: |
| 119 | return sv_type == SVt_PVGV; |
| 120 | default: |
| 121 | return 0; |
| 122 | } |
| 123 | } |
| 124 | |
| 3fd56b4d |
125 | HV *_get_namespace(SV *self) |
| 126 | { |
| 127 | dSP; |
| 128 | SV *ret; |
| 129 | |
| 130 | PUSHMARK(SP); |
| 131 | XPUSHs(self); |
| 132 | PUTBACK; |
| 133 | |
| 134 | call_method("namespace", G_SCALAR); |
| 135 | |
| 136 | SPAGAIN; |
| 137 | ret = POPs; |
| 138 | PUTBACK; |
| 139 | |
| 140 | return (HV*)SvRV(ret); |
| 141 | } |
| 142 | |
| 59017825 |
143 | MODULE = Package::Stash PACKAGE = Package::Stash |
| 144 | |
| be2a7e99 |
145 | PROTOTYPES: DISABLE |
| 146 | |
| 59017825 |
147 | SV* |
| 148 | new(class, package_name) |
| 149 | char *class |
| 150 | SV *package_name |
| 151 | INIT: |
| 152 | HV *instance; |
| 153 | HV *namespace; |
| 154 | CODE: |
| 155 | if (!SvPOK(package_name)) |
| 156 | croak("The constructor argument must be the name of a package"); |
| 157 | |
| 158 | instance = newHV(); |
| 159 | |
| 160 | hv_store(instance, "name", 4, package_name, 0); |
| 161 | namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD); |
| 162 | hv_store(instance, "namespace", 9, newRV((SV*)namespace), 0); |
| 163 | |
| 164 | RETVAL = sv_bless(newRV((SV*)instance), gv_stashpv(class, 0)); |
| 165 | OUTPUT: |
| 166 | RETVAL |
| 194acf47 |
167 | |
| 168 | SV* |
| 169 | name(self) |
| 170 | SV *self |
| 171 | INIT: |
| 172 | SV **slot; |
| 173 | CODE: |
| 174 | if (!sv_isobject(self)) |
| 175 | croak("Can't call name as a class method"); |
| 176 | slot = hv_fetch((HV*)SvRV(self), "name", 4, 0); |
| 177 | RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef; |
| 178 | OUTPUT: |
| 179 | RETVAL |
| 180 | |
| 181 | SV* |
| 182 | namespace(self) |
| 183 | SV *self |
| 184 | INIT: |
| 185 | SV **slot; |
| 186 | CODE: |
| 187 | if (!sv_isobject(self)) |
| 188 | croak("Can't call namespace as a class method"); |
| 189 | slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0); |
| 190 | RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef; |
| 191 | OUTPUT: |
| 192 | RETVAL |
| 3fd56b4d |
193 | |
| 194 | void |
| 195 | remove_package_glob(self, name) |
| 196 | SV *self |
| 197 | char *name |
| 198 | INIT: |
| 199 | HV *namespace; |
| 200 | CODE: |
| 201 | hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD); |
projects / gitmo/Package-Stash-XS.git / blame