cvs commit: modperl-2.0/src/modules/perl modperl_const.c modperl_const.h

[dougm]

dougm       01/04/11 15:48:29

  Added:       src/modules/perl modperl_const.c modperl_const.h
  Log:
  module for compiling/exporting constants
  
  Revision  Changes    Path
  1.1                  modperl-2.0/src/modules/perl/modperl_const.c
  
  Index: modperl_const.c
  ===================================================================
  #include "mod_perl.h"
  #include "modperl_const.h"
  
  typedef int (*constants_lookup)(const char *);
  typedef const char ** (*constants_group_lookup)(const char *);
  
  static int 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, FALSE);
      int val;
  
      /* dont redefine */
      if (!(gvp && GvCV(*gvp))) {
          CV *cv;
  
          val = (*lookup)(name);
  
  #if 0
          fprintf(stderr, "newCONSTSUB(%s, %s, %d)\n",
                  HvNAME(stash), name, val);
  #endif
  
          cv = newCONSTSUB(stash, (char *)name, newSViv(val));
  
          gvp = &CvGV(cv);
      }
      
      /* export into callers namespace */
      if (gvp && 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);
      }
  
      return val;
  }
  
  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 {
          lookup       = modperl_constants_lookup_apache;
          group_lookup = modperl_constants_group_lookup_apache;
      }
  
      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 {
          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(...)");
      }
  
      classname = *(stashname + 1) == 'P' ? "APR" : "Apache";
      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_YES;
  }
  
  
  
  1.1                  modperl-2.0/src/modules/perl/modperl_const.h
  
  Index: modperl_const.h
  ===================================================================
  #ifndef MODPERL_CONST_H
  #define MODPERL_CONST_H
  
  #include "modperl_constants.h"
  
  int modperl_const_compile(pTHX_ const char *classname,
                            const char *arg,
                            const char *name);
  
  XS(XS_modperl_const_compile);
  
  #endif /* MODPERL_CONST_H */