| /* Copyright 2001-2005 The Apache Software Foundation |
| * |
| * Licensed under the Apache License, Version 2.0 (the "License"); |
| * you may not use this file except in compliance with the License. |
| * You may obtain a copy of the License at |
| * |
| * http://www.apache.org/licenses/LICENSE-2.0 |
| * |
| * Unless required by applicable law or agreed to in writing, software |
| * distributed under the License is distributed on an "AS IS" BASIS, |
| * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| * See the License for the specific language governing permissions and |
| * limitations under the License. |
| */ |
| |
| #include "mod_perl.h" |
| #include "modperl_const.h" |
| |
| typedef SV *(*constants_lookup)(pTHX_ const char *); |
| typedef const char ** (*constants_group_lookup)(const char *); |
| |
| static void new_constsub(pTHX_ constants_lookup lookup, |
| HV *caller_stash, HV *stash, |
| const char *name) |
| { |
| int name_len = strlen(name); |
| GV **gvp = (GV **)hv_fetch(stash, name, name_len, TRUE); |
| |
| /* dont redefine */ |
| if (!isGV(*gvp) || !GvCV(*gvp)) { |
| SV *val = (*lookup)(aTHX_ name); |
| |
| #if 0 |
| Perl_warn(aTHX_ "newCONSTSUB(%s, %s, %s)\n", |
| HvNAME(stash), name, SvPV_nolen(val)); |
| #endif |
| |
| newCONSTSUB(stash, (char *)name, val); |
| #ifdef GvSHARED |
| GvSHARED_on(*gvp); |
| #endif |
| } |
| |
| /* export into callers namespace */ |
| if (caller_stash) { |
| GV *alias = *(GV **)hv_fetch(caller_stash, |
| (char *)name, name_len, TRUE); |
| |
| if (!isGV(alias)) { |
| gv_init(alias, caller_stash, name, name_len, TRUE); |
| } |
| |
| GvCV(alias) = GvCV(*gvp); |
| } |
| } |
| |
| int modperl_const_compile(pTHX_ const char *classname, |
| const char *arg, |
| const char *name) |
| { |
| HV *stash = gv_stashpv(classname, TRUE); |
| HV *caller_stash = Nullhv; |
| constants_lookup lookup; |
| constants_group_lookup group_lookup; |
| |
| if (strnEQ(classname, "APR", 3)) { |
| lookup = modperl_constants_lookup_apr; |
| group_lookup = modperl_constants_group_lookup_apr; |
| } |
| else if (strnEQ(classname, "Apache2", 7)) { |
| lookup = modperl_constants_lookup_apache2; |
| group_lookup = modperl_constants_group_lookup_apache2; |
| } |
| else { |
| lookup = modperl_constants_lookup_modperl; |
| group_lookup = modperl_constants_group_lookup_modperl; |
| } |
| |
| if (*arg != '-') { |
| /* only export into callers namespace without -compile arg */ |
| caller_stash = gv_stashpv(arg, TRUE); |
| } |
| |
| if (*name == ':') { |
| int i; |
| const char **group; |
| |
| name++; |
| |
| group = (*group_lookup)(name); |
| |
| for (i=0; group[i]; i++) { |
| new_constsub(aTHX_ lookup, caller_stash, stash, group[i]); |
| } |
| } |
| else { |
| if (*name == '&') { |
| name++; |
| } |
| new_constsub(aTHX_ lookup, caller_stash, stash, name); |
| } |
| |
| return 1; |
| } |
| |
| XS(XS_modperl_const_compile) |
| { |
| I32 i; |
| STRLEN n_a; |
| char *stashname = HvNAME(GvSTASH(CvGV(cv))); |
| const char *classname, *arg; |
| dXSARGS; |
| |
| if (items < 2) { |
| Perl_croak(aTHX_ "Usage: %s->compile(...)", stashname); |
| } |
| |
| classname = *(stashname + 1) == 'P' |
| ? "APR" |
| : (*stashname == 'A' ? "Apache2" : "ModPerl"); |
| arg = SvPV(ST(1),n_a); |
| |
| for (i=2; i<items; i++) { |
| (void)modperl_const_compile(aTHX_ classname, arg, SvPV(ST(i), n_a)); |
| } |
| |
| XSRETURN_EMPTY; |
| } |