-:    0:Source:modperl_const.c
        -:    0:Object:modperl_const.bb
        -:    1:/* Copyright 2001-2004 The Apache Software Foundation
        -:    2: *
        -:    3: * Licensed under the Apache License, Version 2.0 (the "License");
        -:    4: * you may not use this file except in compliance with the License.
        -:    5: * You may obtain a copy of the License at
        -:    6: *
        -:    7: *     http://www.apache.org/licenses/LICENSE-2.0
        -:    8: *
        -:    9: * Unless required by applicable law or agreed to in writing, software
        -:   10: * distributed under the License is distributed on an "AS IS" BASIS,
        -:   11: * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
        -:   12: * See the License for the specific language governing permissions and
        -:   13: * limitations under the License.
        -:   14: */
        -:   15:
        -:   16:#include "mod_perl.h"
        -:   17:#include "modperl_const.h"
        -:   18:
        -:   19:typedef SV *(*constants_lookup)(pTHX_ const char *);
        -:   20:typedef const char ** (*constants_group_lookup)(const char *);
        -:   21:
        -:   22:static void new_constsub(pTHX_ constants_lookup lookup,
        -:   23:                        HV *caller_stash, HV *stash,
        -:   24:                        const char *name)
      927:   25:{
      927:   26:    int name_len = strlen(name);
      927:   27:    GV **gvp = (GV **)hv_fetch(stash, name, name_len, TRUE);
        -:   28:
        -:   29:    /* dont redefine */
      927:   30:    if (!isGV(*gvp) || !GvCV(*gvp)) {
      252:   31:        SV *val = (*lookup)(aTHX_ name);
        -:   32:
        -:   33:#if 0
        -:   34:        fprintf(stderr, "newCONSTSUB(%s, %s, %d)\n",
        -:   35:                HvNAME(stash), name, val);
        -:   36:#endif
        -:   37:
      252:   38:        newCONSTSUB(stash, (char *)name, val);
        -:   39:#ifdef GvSHARED
        -:   40:        GvSHARED_on(*gvp);
        -:   41:#endif
        -:   42:    }
        -:   43:    
        -:   44:    /* export into callers namespace */
      927:   45:    if (caller_stash) {
       26:   46:        GV *alias = *(GV **)hv_fetch(caller_stash,
        -:   47:                                     (char *)name, name_len, TRUE);
        -:   48:
       26:   49:        if (!isGV(alias)) {
       26:   50:            gv_init(alias, caller_stash, name, name_len, TRUE);
        -:   51:        }
        -:   52:
       26:   53:        GvCV(alias) = GvCV(*gvp);
        -:   54:    }
        -:   55:}
        -:   56:
        -:   57:int modperl_const_compile(pTHX_ const char *classname,
        -:   58:                          const char *arg,
        -:   59:                          const char *name)
      722:   60:{
      722:   61:    HV *stash = gv_stashpv(classname, TRUE);
      722:   62:    HV *caller_stash = Nullhv;
      722:   63:    constants_lookup lookup;
      722:   64:    constants_group_lookup group_lookup;
        -:   65:
      722:   66:    if (strnEQ(classname, "APR", 3)) {
       70:   67:        lookup       = modperl_constants_lookup_apr;
       70:   68:        group_lookup = modperl_constants_group_lookup_apr;
        -:   69:    }
        -:   70:    else {
      652:   71:        lookup       = modperl_constants_lookup_apache;
      652:   72:        group_lookup = modperl_constants_group_lookup_apache;
        -:   73:    }
        -:   74:
      722:   75:    if (*arg != '-') {
        -:   76:        /* only export into callers namespace without -compile arg */
       19:   77:        caller_stash = gv_stashpv(arg, TRUE);
        -:   78:    }
        -:   79:
      722:   80:    if (*name == ':') {
       53:   81:        int i;
       53:   82:        const char **group;
        -:   83:
       53:   84:        name++;
        -:   85:
       53:   86:        group = (*group_lookup)(name);
        -:   87:
      311:   88:        for (i=0; group[i]; i++) {
      258:   89:            new_constsub(aTHX_ lookup, caller_stash, stash, group[i]);
        -:   90:        }
        -:   91:    }
        -:   92:    else {
      669:   93:        if (*name == '&') {
        6:   94:            name++;
        -:   95:        }
      669:   96:        new_constsub(aTHX_ lookup, caller_stash, stash, name);
        -:   97:    }
        -:   98:
      722:   99:    return 1;
        -:  100:}
        -:  101:
        -:  102:XS(XS_modperl_const_compile)
      474:  103:{
      474:  104:    I32 i;
      474:  105:    STRLEN n_a;
      474:  106:    char *stashname = HvNAME(GvSTASH(CvGV(cv)));
      474:  107:    const char *classname, *arg;
      474:  108:    dXSARGS;
        -:  109:
      474:  110:    if (items < 2) {
    #####:  111:        Perl_croak(aTHX_ "Usage: %s->compile(...)", stashname);
        -:  112:    }
        -:  113:
      474:  114:    classname = *(stashname + 1) == 'P' ? "APR" : "Apache";
      474:  115:    arg = SvPV(ST(1),n_a);
        -:  116:
     1196:  117:    for (i=2; i<items; i++) {
      722:  118:        (void)modperl_const_compile(aTHX_ classname, arg, SvPV(ST(i), n_a));
        -:  119:    }
        -:  120:
      474:  121:    XSRETURN_EMPTY;
        -:  122:}